diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,39 @@ +# 0.7 -- 2024-02-05 + +* Add `TypedOverride`, `SomeTypedOverride`, and `runTypedOverride` to + `Lang.Crucible.Simulator.OverrideSim`. These allow one to define an + `OverrideSim` action and bundle `TypeRepr`s for its argument and result + types, which is a common pattern in several Crucible backends. +* Add `Lang.Crucible.Simulator.OverrideSim.bindCFG`, a utility function for + binding a CFG to its handle in an `OverrideSim`. + +# 0.6 + +* Separate backend data structures. The "symbolic backend" is a +ubiquitous datatype throughout Crucible. Previously, this single +data structure was responsible for symbolic expression creation +and also for tracking the structure of assumptions and assertions +as the symbolic simulator progresses. These linked purposes made +certain code patterns very difficult, such as running related symbolic +simulation instances in separate threads, or configuring different +online solvers for path satisfiability checking. + +We changed this structure so that the `sym` value is now only +responsible for the What4 expression creation tasks. Now, there is a +new "symbolic backend" `bak` value (that contains a `sym`) which is +used to handle path conditions and assertions. These two values are +connected by the `IsSymBackend sym bak` type class. To prevent even +more code churn than is already occurring, the exact type of `bak` is +wrapped up into an existential datatype and stored in the +`SimContext`. This makes accessing the symbolic backend a little less +convenient, but prevents the new type from leaking into every type +signature that currently mentions `sym`. The `withBackend` +and `ovrWithBackend` operations (written in a CPS style) are the +easiest way to get access to the backend, but it can also be accessed +via directly pattern matching on the existential `SomeBackend` type. + +For many purposes the old `sym` value is still sufficient, and the +`bak` value is not necessary. A good rule is that any operation +that adds assumptions or assertions to the context will need +the full symbolic backend `bak`, but any operation that just +builds terms will only need the `sym`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2022 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/crucible.cabal b/crucible.cabal new file mode 100644 --- /dev/null +++ b/crucible.cabal @@ -0,0 +1,164 @@ +Cabal-version: 2.2 +Name: crucible +Version: 0.7 +Author: Galois Inc. +Maintainer: rscott@galois.com, kquick@galois.com, langston@galois.com +Copyright: (c) Galois, Inc 2014-2022 +License: BSD-3-Clause +License-file: LICENSE +Build-type: Simple +Category: Language +Synopsis: Crucible is a library for language-agnostic symbolic simulation +Description: + Crucible provides a program representation format based on single-static assignment + (SSA) form control flow graphs, and a symbolic simulation engine for executing + programs expressed in this format. It also provides support for communicating with + a variety of SAT and SMT solvers, including Z3, CVC4, Yices, STP, and dReal. +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/GaloisInc/crucible + subdir: crucible + +-- Many (but not all, sadly) uses of unsafe operations are +-- controlled by this compile flag. When this flag is set +-- to False, alternate implementations are used to avoid +-- Unsafe.Coerce and Data.Coerce. These alternate implementations +-- impose a significant performance hit. +flag unsafe-operations + Description: Use unsafe operations to improve performance + Default: True + +common bldflags + ghc-options: -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -Werror=overlapping-patterns + -Wpartial-fields + -Wincomplete-uni-patterns + ghc-prof-options: -O2 -fprof-auto-exported + default-language: Haskell2010 + + +library + import: bldflags + build-depends: + base >= 4.13 && < 4.19, + bimap, + bv-sized >= 1.0.0 && < 1.1, + containers >= 0.5.9.0, + exceptions, + fgl, + hashable, + json >= 0.9 && < 1.0, + lens, + mtl, + panic >= 0.3, + parameterized-utils >= 1.0.8 && < 2.2, + prettyprinter >= 1.7.0, + template-haskell, + text, + time >= 1.8 && < 2.0, + th-abstraction >=0.1 && <0.6, + transformers, + unordered-containers, + vector, + what4 >= 0.4 + + default-extensions: + NondecreasingIndentation + NoStarIsType + + hs-source-dirs: src + + exposed-modules: + Lang.Crucible.Analysis.DFS + Lang.Crucible.Analysis.ForwardDataflow + Lang.Crucible.Analysis.Fixpoint + Lang.Crucible.Analysis.Fixpoint.Components + Lang.Crucible.Analysis.Postdom + Lang.Crucible.Analysis.Reachable + Lang.Crucible.Backend + Lang.Crucible.Backend.AssumptionStack + Lang.Crucible.Backend.ProofGoals + Lang.Crucible.Backend.Online + Lang.Crucible.Backend.Simple + Lang.Crucible.CFG.Common + Lang.Crucible.CFG.Core + Lang.Crucible.CFG.Expr + Lang.Crucible.CFG.Extension + Lang.Crucible.CFG.ExtractSubgraph + Lang.Crucible.CFG.Generator + Lang.Crucible.CFG.Reg + Lang.Crucible.CFG.SSAConversion + Lang.Crucible.CFG.EarlyMergeLoops + Lang.Crucible.FunctionHandle + Lang.Crucible.Simulator + Lang.Crucible.Simulator.Breakpoint + Lang.Crucible.Simulator.BoundedExec + Lang.Crucible.Simulator.BoundedRecursion + Lang.Crucible.Simulator.CallFrame + Lang.Crucible.Simulator.Evaluation + Lang.Crucible.Simulator.EvalStmt + Lang.Crucible.Simulator.ExecutionTree + Lang.Crucible.Simulator.Intrinsics + Lang.Crucible.Simulator.GlobalState + Lang.Crucible.Simulator.Operations + Lang.Crucible.Simulator.OverrideSim + Lang.Crucible.Simulator.PathSatisfiability + Lang.Crucible.Simulator.PathSplitting + Lang.Crucible.Simulator.PositionTracking + Lang.Crucible.Simulator.Profiling + Lang.Crucible.Simulator.RegMap + Lang.Crucible.Simulator.RegValue + Lang.Crucible.Simulator.SimError + Lang.Crucible.Simulator.SymSequence + Lang.Crucible.Syntax + Lang.Crucible.Types + Lang.Crucible.Vector + Lang.Crucible.Panic + Lang.Crucible.Utils.BitSet + Lang.Crucible.Utils.CoreRewrite + Lang.Crucible.Utils.MonadVerbosity + Lang.Crucible.Utils.MuxTree + Lang.Crucible.Utils.PrettyPrint + Lang.Crucible.Utils.RegRewrite + Lang.Crucible.Utils.StateContT + Lang.Crucible.Utils.Structural + + if flag(unsafe-operations) + cpp-options: -DUNSAFE_OPS + +test-suite absint-tests + import: bldflags + type: exitcode-stdio-1.0 + hs-source-dirs: test/absint + other-modules: AI, + EvenOdd, + Max, + WTO + main-is: Main.hs + build-depends: base, + containers, + mtl, + crucible, + what4, + parameterized-utils, + tasty >= 0.10, + tasty-hunit >= 0.9, + tasty-quickcheck >= 0.8, + QuickCheck + +test-suite helper-tests + import: bldflags + type: exitcode-stdio-1.0 + hs-source-dirs: test/helpers +-- other-modules: + main-is: Main.hs + build-depends: base, + hspec >= 2.5, + crucible, + panic >= 0.3, + tasty >= 0.10, + tasty-hspec >= 1.1 diff --git a/src/Lang/Crucible/Analysis/DFS.hs b/src/Lang/Crucible/Analysis/DFS.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/DFS.hs @@ -0,0 +1,227 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Analysis.DFS +-- Description : Depth-first search algorithm on Crucible CFGs +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module defines a generic algorithm for depth-first search +-- traversal of a control flow graph. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Lang.Crucible.Analysis.DFS +( -- * Basic DFS types and algorithms + DFSEdgeType(..) +, DFSNodeFunc +, DFSEdgeFunc +, dfs +, run_dfs + + -- * Some specific DFS traversals +, dfs_backedge_targets +, dfs_backedges +, dfs_list +, dfs_preorder +, dfs_postorder +) where + +import Prelude hiding (foldr) +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Foldable + +import Lang.Crucible.Types +import Lang.Crucible.CFG.Core + +type SomeBlockID blocks = Some (BlockID blocks) + +data DFSEdgeType + = TreeEdge -- ^ This edge is on the spanning forrest computed by this DFS + | ForwardOrCrossEdge -- ^ This edge is either a forward (to a direct decendent in the spanning tree) + -- or a cross edge (to a cousin node) + | BackEdge -- ^ This edge is a back edge (to an ancestor in the spanning tree). Every cycle in + -- the graph must traverse at least one back edge. + deriving (Eq, Ord, Show) + +-- | Function to update the traversal state when we have finished visiting +-- all of a nodes's reachable children. +type DFSNodeFunc ext blocks a = forall ret ctx. Block ext blocks ret ctx -> a -> a + +-- | Function to update the traversal state when traversing an edge. +type DFSEdgeFunc blocks a = DFSEdgeType -> SomeBlockID blocks -> SomeBlockID blocks -> a -> a + + +-- | Use depth-first search to calculate a set of all the block IDs that +-- are the target of some back-edge, i.e., a set of nodes through which +-- every loop passes. +dfs_backedge_targets :: CFG ext blocks init ret -> Set (SomeBlockID blocks) +dfs_backedge_targets = + dfs (\_ x -> x) + (\et _ m x -> + case et of + BackEdge -> Set.insert m x + _ -> x) + Set.empty + + +-- | Compute a sequence of all the back edges found in a depth-first search of the given CFG. +dfs_backedges :: CFG ext blocks init ret -> Seq (SomeBlockID blocks, SomeBlockID blocks) +dfs_backedges = + dfs (\_ x -> x) + (\et n m x -> + case et of + BackEdge -> x Seq.|> (n,m) + _ -> x) + Seq.empty + +{- +dfs_backedges_string :: CFG blocks init ret -> String +dfs_backedges_string = unlines . map showEdge . toList . dfs_backedges + where showEdge :: (SomeBlockID blocks, SomeBlockID blocks) -> String + showEdge (Some n, Some m) = show (n,m) +-} + +-- | Compute a sequence of all the edges visited in a depth-first search of the given CFG. +dfs_list :: CFG ext blocks init ret -> Seq (DFSEdgeType, SomeBlockID blocks, SomeBlockID blocks) +dfs_list = + dfs (\_ x -> x) + (\et n m x -> x Seq.|> (et,n,m)) + Seq.empty + +-- | Compute a postorder traversal of all the reachable nodes in the CFG +dfs_postorder :: CFG ext blocks init ret -> Seq (SomeBlockID blocks) +dfs_postorder = + dfs (\blk x -> x Seq.|> (Some (blockID blk))) + (\_ _ _ x -> x) + Seq.empty + +-- | Compute a preorder traversal of all the reachable nodes in the CFG +dfs_preorder :: CFG ext blocks init ret -> Seq (SomeBlockID blocks) +dfs_preorder = + dfs (\_ x -> x) + (\et _n m x -> + case et of + TreeEdge -> x Seq.|> m + _ -> x) + Seq.empty + +{- +dfs_list_string :: CFG blocks init ret -> String +dfs_list_string = unlines . map showEdge . toList . dfs_list + where showEdge :: (DFSEdgeType, SomeBlockID blocks, SomeBlockID blocks) -> String + showEdge (et, Some n, Some m) = show (et,n,m) +-} + +-- | A depth-first search algorithm on a block map. +-- +-- The DFSNodeFunc and DFSEdgeFunc define what we are computing. The DFSEdgeFunc is called +-- on each edge. The edges are classified according to standard depth-first search +-- terminology. A tree edge is an edge in the discovered spanning tree. A back edge +-- goes from a child to an ancestor in the spanning tree. A ForwardOrCross edge travels +-- either from an ancestor to a child (but not a tree edge), or between two unrelated nodes. +-- The forward/cross case can be distinguished, if desired, by tracking the order in which +-- nodes are found. A forward edge goes from a low numbered node to a high numbered node, +-- but a cross edge goes from a high node to a low node. +-- +-- The DFSNodeFunc is called on each block _after_ the DFS has processed all its fresh reachable +-- children; that is, as the search is leaving the given node. In particular, using the DFSNodeFunc +-- to put the blocks in a queue will give a postorder traversal of the discovered nodes. +-- Contrarywise, using the DFSEdgeFunc to place blocks in a queue when they occur in a TreeEdge +-- will give a preorder traversal of the discovered nodes. +-- +-- We track the lifecycle of nodes by using two sets; an ancestor set and a black set. +-- Nodes are added to the ancestor set as we pass down into recursive calls, and changes +-- to this set are discarded upon return. The black set records black nodes (those whose +-- visit is completed), and changes are threaded through the search. +-- +-- In the standard parlance, a node is white if it has not yet been discovered; it is +-- in neither the ancestor nor black set. A node is grey if it has been discovered, but +-- not yet completed; such a node is in the ancestor set, but not the black set. A node +-- is black if its visit has been completed; it is in the black set and not in the ancestor +-- set. INVARIANT: at all times, the ancestor set and black set are disjoint. +-- After a DFS is completed, all visited nodes will be in the black set; any nodes not in the +-- black set are unreachable from the initial node. + +dfs :: DFSNodeFunc ext blocks a + -> DFSEdgeFunc blocks a + -> a + -> CFG ext blocks init ret + -> a +dfs visit edge x cfg = + fst $ run_dfs + visit + edge + (cfgBlockMap cfg) + Set.empty + (cfgEntryBlockID cfg) + (x, Set.empty) + + +-- | Low-level depth-first search function. This exposes more of the moving parts +-- than `dfs` for algorithms that need more access to the guts. +run_dfs :: forall ext blocks a ret cxt + . DFSNodeFunc ext blocks a -- ^ action to take after a visit is finished + -> DFSEdgeFunc blocks a -- ^ action to take for each edge + -> BlockMap ext blocks ret -- ^ CFG blocks to search + -> Set (SomeBlockID blocks) -- ^ ancestor nodes + -> BlockID blocks cxt -- ^ a white node to visit + -> (a, Set (SomeBlockID blocks)) -- ^ Partially-computed value and initial black set + -> (a, Set (SomeBlockID blocks)) -- ^ Computed value and modified black set +run_dfs visit edge bm = visit_id + + where visit_id :: forall cxt' + . Set (SomeBlockID blocks) + -> BlockID blocks cxt' + -> (a, Set (SomeBlockID blocks)) + -> (a, Set (SomeBlockID blocks)) + visit_id an i (x,black) = + let block = getBlock i bm + -- Insert index 'i' into the ancestor set before the recursive call + (x',black') = visit_block (Set.insert (Some i) an) block (x, black) + + -- After the recursive call has completed, add 'i' to the black set + -- and call the node visit function + in (visit block x', Set.insert (Some i) black') + + visit_block :: Set (SomeBlockID blocks) + -> Block ext blocks ret ctx + -> (a, Set (SomeBlockID blocks)) + -> (a, Set (SomeBlockID blocks)) + visit_block an block = + -- Get a list of all the next block ids we might jump to next, and visit them one by one, + -- composting together their effects on the partial computation and black set. + withBlockTermStmt block $ \_loc t -> + foldr (\m f -> f . visit_edge an (Some (blockID block)) m) id + $ fromMaybe [] $ termStmtNextBlocks t + + -- Given source and target block ids, examine the ancestor and black sets + -- to discover if the node we are about to visit is a white, grey or black node + -- and classify the edge accordingly. Recursively visit the target node if it is white. + visit_edge :: Set (SomeBlockID blocks) -- ^ ancestor set + -> SomeBlockID blocks -- ^ source block id + -> SomeBlockID blocks -- ^ target block id + -> (a, Set (SomeBlockID blocks)) + -> (a, Set (SomeBlockID blocks)) + visit_edge an n m@(Some m') (x, black) + | Set.member m an = -- grey node, back edge + (edge BackEdge n m x, black) + + | Set.member m black = -- black node, forward/cross edge + (edge ForwardOrCrossEdge n m x, black) + + | otherwise = -- white node, tree edge; recusively visit + visit_id an m' (edge TreeEdge n m x, black) diff --git a/src/Lang/Crucible/Analysis/Fixpoint.hs b/src/Lang/Crucible/Analysis/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/Fixpoint.hs @@ -0,0 +1,885 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Analysis.Fixpoint +-- Description : Abstract interpretation over SSA function CFGs +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- Maintainer : Tristan Ravitch +-- Stability : provisional +-- +-- Abstract interpretation over the Crucible IR +-- +-- Supports widening with an iteration order based on weak +-- topological orderings. Some basic tests on hand-written IR +-- programs are included. +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Analysis.Fixpoint ( + -- * Entry point + forwardFixpoint, + forwardFixpoint', + ScopedReg(..), + lookupAbstractScopedRegValue, + lookupAbstractScopedRegValueByIndex, + Ignore(..), + -- * Abstract Domains + Domain(..), + IterationStrategy(..), + Interpretation(..), + PointAbstraction(..), + RefSet, + emptyRefSet, + paGlobals, + paRegisters, + lookupAbstractRegValue, + modifyAbstractRegValue, + cfgWeakTopologicalOrdering, + -- * Pointed domains + -- $pointed + Pointed(..), + pointed + ) where + +import Control.Applicative +import Control.Lens.Operators ( (^.), (%=), (.~), (&), (%~) ) +import qualified Control.Monad.State.Strict as St +import qualified Data.Functor.Identity as I +import Data.Kind +import qualified Data.Set as S +import Text.Printf + +import Prelude + +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as PU +import qualified Data.Parameterized.Map as PM +import qualified Data.Parameterized.TraversableFC as PU + +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Extension +import Lang.Crucible.Analysis.Fixpoint.Components + +-- | A wrapper around widening strategies +data WideningStrategy = WideningStrategy (Int -> Bool) + +-- | A wrapper around widening operators. This is mostly here to +-- avoid requiring impredicative types later. +data WideningOperator dom = WideningOperator (forall tp . dom tp -> dom tp -> dom tp) + +-- | The iteration strategies available for computing fixed points. +-- +-- Algorithmically, the best strategies seem to be based on Weak +-- Topological Orders (WTOs). The WTO approach also naturally +-- supports widening (with a specified widening strategy and widening +-- operator). +-- +-- A simple worklist approach is also available. +data IterationStrategy (dom :: CrucibleType -> Type) where + WTO :: IterationStrategy dom + WTOWidening :: (Int -> Bool) -> (forall tp . dom tp -> dom tp -> dom tp) -> IterationStrategy dom + Worklist :: IterationStrategy dom + +-- | A domain of abstract values, parameterized by a term type +data Domain (dom :: CrucibleType -> Type) = + Domain { domTop :: forall tp . dom tp + , domBottom :: forall tp . dom tp + , domJoin :: forall tp . dom tp -> dom tp -> dom tp + , domIter :: IterationStrategy dom + , domEq :: forall tp . dom tp -> dom tp -> Bool + } + +-- | Transfer functions for each statement type +-- +-- Interpretation functions for some statement types -- +-- e.g. @interpExpr@ and @interpExt@ -- receive 'ScopedReg' arguments +-- corresponding to the SSA tmp that the result of the interpreted +-- statement get assigned to. Some interpretation functions that could +-- receive this argument do not -- e.g. @interpCall@ -- because +-- conathan didn't have a use for that. +data Interpretation ext (dom :: CrucibleType -> Type) = + Interpretation { interpExpr :: forall blocks ctx tp + . ScopedReg + -> TypeRepr tp + -> Expr ext ctx tp + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), dom tp) + , interpExt :: forall blocks ctx tp + . ScopedReg + -> StmtExtension ext (Reg ctx) tp + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), dom tp) + , interpCall :: forall blocks ctx args ret + . CtxRepr args + -> TypeRepr ret + -> Reg ctx (FunctionHandleType args ret) + -> dom (FunctionHandleType args ret) + -> PU.Assignment dom args + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), dom ret) + , interpReadGlobal :: forall blocks ctx tp + . GlobalVar tp + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), dom tp) + , interpWriteGlobal :: forall blocks ctx tp + . GlobalVar tp + -> Reg ctx tp + -> PointAbstraction blocks dom ctx + -> Maybe (PointAbstraction blocks dom ctx) + , interpBr :: forall blocks ctx + . Reg ctx BoolType + -> dom BoolType + -> JumpTarget blocks ctx + -> JumpTarget blocks ctx + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), Maybe (PointAbstraction blocks dom ctx)) + , interpMaybe :: forall blocks ctx tp + . TypeRepr tp + -> Reg ctx (MaybeType tp) + -> dom (MaybeType tp) + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks dom ctx), dom tp, Maybe (PointAbstraction blocks dom ctx)) + } + +-- | This abstraction contains the abstract values of each register at +-- the program point represented by the abstraction. It also contains +-- a map of abstractions for all of the global variables currently +-- known. +data PointAbstraction blocks dom ctx = + PointAbstraction { _paGlobals :: PM.MapF GlobalVar dom + , _paRegisters :: PU.Assignment dom ctx + , _paRefs :: PM.MapF (RefStmtId blocks) dom + -- ^ In this map, the keys are really just the 'StmtId's in + -- '_paRegisterRefs', but with a newtype wrapper that unwraps + -- a level of their 'ReferenceType` type rep. + , _paRegisterRefs :: PU.Assignment (RefSet blocks) ctx + -- ^ This mapping records the *set* of references (named by + -- allocation site) that each register could hold. + } + +-- | This is a wrapper around 'StmtId' that exposes the underlying type of a +-- 'ReferenceType', and is needed to define the abstract value we carry around. +newtype RefStmtId blocks tp = RefStmtId (StmtId blocks (ReferenceType tp)) + +-- | This type names an allocation site in a program. +-- +-- Allocation sites are named by their basic block and their index into that +-- containing basic block. We have to carry around the type repr for inspection +-- later (especially in instances). +data StmtId blocks tp = StmtId (TypeRepr tp) (Some (BlockID blocks)) Int + deriving (Show) + +instance Eq (StmtId blocks tp) where + StmtId tp1 bid1 ix1 == StmtId tp2 bid2 ix2 = + case testEquality tp1 tp2 of + Nothing -> False + Just Refl -> (bid1, ix1) == (bid2, ix2) + +instance Ord (StmtId blocks tp) where + compare (StmtId tp1 bid1 ix1) (StmtId tp2 bid2 ix2) = + case toOrdering (compareF tp1 tp2) of + LT -> LT + GT -> GT + EQ -> compare (bid1, ix1) (bid2, ix2) + +instance TestEquality (RefStmtId blocks) where + testEquality (RefStmtId (StmtId tp1 (Some bid1) idx1)) (RefStmtId (StmtId tp2 (Some bid2) idx2)) = do + Refl <- testEquality tp1 tp2 + Refl <- testEquality bid1 bid2 + case idx1 == idx2 of + True -> return $! Refl + False -> Nothing + +instance OrdF (RefStmtId blocks) where + compareF (RefStmtId (StmtId tp1 (Some bid1) idx1)) (RefStmtId (StmtId tp2 (Some bid2) idx2)) = + case compareF tp1 tp2 of + EQF -> + case compareF bid1 bid2 of + EQF -> + case compare idx1 idx2 of + LT -> LTF + GT -> GTF + EQ -> EQF + LTF -> LTF + GTF -> GTF + LTF -> LTF + GTF -> GTF + +-- | This is a wrapper around a set of 'StmtId's that name allocation sites of +-- references. We need the wrapper to correctly position the @tp@ type +-- parameter so that we can put them in an 'PU.Assignment'. +newtype RefSet blocks tp = RefSet (S.Set (StmtId blocks tp)) + +emptyRefSet :: RefSet blocks tp +emptyRefSet = RefSet S.empty + +unionRefSets :: RefSet blocks tp -> RefSet blocks tp -> RefSet blocks tp +unionRefSets (RefSet s1) (RefSet s2) = RefSet (s1 `S.union` s2) + +instance ShowF dom => Show (PointAbstraction blocks dom ctx) where + show pa = show (_paRegisters pa) + +instance ShowF dom => ShowF (PointAbstraction blocks dom) + +-- | Look up the abstract value of a register at a program point +lookupAbstractRegValue :: PointAbstraction blocks dom ctx -> Reg ctx tp -> dom tp +lookupAbstractRegValue pa (Reg ix) = (pa ^. paRegisters) PU.! ix + +-- | Modify the abstract value of a register at a program point +modifyAbstractRegValue :: PointAbstraction blocks dom ctx + -> Reg ctx tp + -> (dom tp -> dom tp) + -> PointAbstraction blocks dom ctx +modifyAbstractRegValue pa (Reg ix) f = pa & paRegisters . ixF ix %~ f + +-- | The `FunctionAbstraction` contains the abstractions for the entry +-- point of each basic block in the function, as well as the final +-- abstract value for the returned register. +data FunctionAbstraction (dom :: CrucibleType -> Type) blocks ret = + FunctionAbstraction { _faEntryRegs :: PU.Assignment (PointAbstraction blocks dom) blocks + -- ^ Mapping from blocks to point abstractions + -- at entry to blocks. + , _faExitRegs :: PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks + -- ^ Mapping from blocks to point abstractions + -- at exit from blocks. Blocks are indexed by + -- their entry context, but not by there exit + -- contexts, so we wrap the point abstraction + -- in @Ignore . Some@ to hide the context of + -- SSA tmps at exit. + , _faRet :: dom ret + -- ^ Abstract value at return from function. + } + +data IterationState (dom :: CrucibleType -> Type) blocks ret = + IterationState { _isFuncAbstr :: FunctionAbstraction dom blocks ret + , _isRetAbstr :: dom ret + , _processedOnce :: S.Set (Some (BlockID blocks)) + } + +newtype M (dom :: CrucibleType -> Type) blocks ret a = M { runM :: St.State (IterationState dom blocks ret) a } + deriving (St.MonadState (IterationState dom blocks ret), Monad, Applicative, Functor) + +-- | Extend the abstraction with a domain value for the next register. +-- +-- The set of references that the register can point to is set to the empty set +extendRegisters :: dom tp -> PointAbstraction blocks dom ctx -> PointAbstraction blocks dom (ctx ::> tp) +extendRegisters domVal pa = + pa { _paRegisters = PU.extend (_paRegisters pa) domVal + , _paRegisterRefs = PU.extend (_paRegisterRefs pa) emptyRefSet + } + +-- | Join two point abstractions using the join operation of the domain. +-- +-- We join registers pointwise. For globals, we explicitly call join +-- when the global is in both maps. If a global is only in one map, +-- there is an implicit join with bottom, which always results in the +-- same element. Since it is a no-op, we just skip it and keep the +-- one present element. +joinPointAbstractions :: forall blocks (dom :: CrucibleType -> Type) ctx + . Domain dom + -> PointAbstraction blocks dom ctx + -> PointAbstraction blocks dom ctx + -> PointAbstraction blocks dom ctx +joinPointAbstractions dom = zipPAWith (domJoin dom) unionRefSets + +zipPAWith :: forall blocks (dom :: CrucibleType -> Type) ctx + . (forall tp . dom tp -> dom tp -> dom tp) + -> (forall tp . RefSet blocks tp -> RefSet blocks tp -> RefSet blocks tp) + -> PointAbstraction blocks dom ctx + -> PointAbstraction blocks dom ctx + -> PointAbstraction blocks dom ctx +zipPAWith domOp refSetOp pa1 pa2 = + pa1 { _paRegisters = PU.zipWith domOp (pa1 ^. paRegisters) (pa2 ^. paRegisters) + , _paGlobals = I.runIdentity $ do + PM.mergeWithKeyM (\_ a b -> return (Just (domOp a b))) return return (pa1 ^. paGlobals) (pa2 ^. paGlobals) + , _paRefs = I.runIdentity $ do + PM.mergeWithKeyM (\_ a b -> return (Just (domOp a b))) return return (pa1 ^. paRefs) (pa2 ^. paRefs) + , _paRegisterRefs = PU.zipWith refSetOp (pa1 ^. paRegisterRefs) (pa2 ^. paRegisterRefs) + } + +-- | Compare two point abstractions for equality. +-- +-- Note that the globals maps are converted to a list and the lists +-- are checked for equality. This should be safe if order is +-- preserved properly in the list functions... +equalPointAbstractions :: forall blocks (dom :: CrucibleType -> Type) ctx + . Domain dom + -> PointAbstraction blocks dom ctx + -> PointAbstraction blocks dom ctx + -> Bool +equalPointAbstractions dom pa1 pa2 = + PU.foldlFC (\a (Ignore b) -> a && b) True pointwiseEqualRegs && equalGlobals + where + checkGlobal (PM.Pair gv1 d1) (PM.Pair gv2 d2) = + case PM.testEquality gv1 gv2 of + Just Refl -> domEq dom d1 d2 + Nothing -> False + equalGlobals = and $ zipWith checkGlobal (PM.toList (pa1 ^. paGlobals)) (PM.toList (pa2 ^. paGlobals)) + pointwiseEqualRegs = PU.zipWith (\a b -> Ignore (domEq dom a b)) (pa1 ^. paRegisters) (pa2 ^. paRegisters) + +---------------------------------------------------------------- + +-- | A CFG-scoped SSA temp register. +-- +-- We don't care about the type params yet, hence the +-- existential quantification. We may want to look up the instruction +-- corresponding to a 'ScopedReg' after analysis though, and we'll +-- surely want to compare 'ScopedReg's for equality, and use them to +-- look up values in point abstractions after analysis. +data ScopedReg where + ScopedReg :: BlockID blocks ctx1 -> Reg ctx2 tp -> ScopedReg +-- The pretty-show library can't parse the derived version, because it +-- doesn't like bare "%" and/or "$" in atoms. +{- deriving instance Show ScopedReg -} +instance Show ScopedReg where + show (ScopedReg b r) = printf "\"%s:%s\"" (show b) (show r) +instance Eq ScopedReg where + sr1 == sr2 = + scopedRegIndexVals sr1 == scopedRegIndexVals sr2 +instance Ord ScopedReg where + sr1 `compare` sr2 = + scopedRegIndexVals sr1 `compare` scopedRegIndexVals sr2 + +scopedRegIndexVals :: ScopedReg -> (Int, Int) +scopedRegIndexVals (ScopedReg b r) = (blockIDIndexVal b, regIndexVal r) + +blockIDIndexVal :: BlockID ctx tp -> Int +blockIDIndexVal = PU.indexVal . blockIDIndex + +regIndexVal :: Reg ctx tp -> Int +regIndexVal = PU.indexVal . regIndex + +---------------------------------------------------------------- + +-- | Lookup the abstract value of scoped reg in an exit assignment. +lookupAbstractScopedRegValue :: ScopedReg + -> PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks + -> Maybe (Some dom) +lookupAbstractScopedRegValue sr ass = + lookupAbstractScopedRegValueByIndex (scopedRegIndexVals sr) ass + +-- | Lookup the abstract value of scoped reg -- specified by 0-based +-- int indices -- in an exit assignment. +lookupAbstractScopedRegValueByIndex :: (Int, Int) + -> PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks + -> Maybe (Some dom) +lookupAbstractScopedRegValueByIndex (b, r) ass = do + Some (Ignore (Some pa)) <- assignmentLookupByIndex b ass + assignmentLookupByIndex r (pa ^. paRegisters) + +-- | Lookup a value in an assignment based on it's 0-based int index. +assignmentLookupByIndex :: Int -> PU.Assignment f ctx -> Maybe (Some f) +assignmentLookupByIndex i ass = + let sz = PU.size ass + in case PU.intIndex i sz of + Nothing -> Nothing + Just (Some ix) -> Just (Some (ass PU.! ix)) + +---------------------------------------------------------------- + +-- | Apply the transfer functions from an interpretation to a block, +-- given a starting set of abstract values. +-- +-- Return a set of blocks to visit later. +transfer :: forall ext dom blocks ret ctx + . Domain dom + -> Interpretation ext dom + -> TypeRepr ret + -> Block ext blocks ret ctx + -> PointAbstraction blocks dom ctx + -> M dom blocks ret (S.Set (Some (BlockID blocks))) +transfer dom interp retRepr blk = transferSeq blockInputSize (_blockStmts blk) + where + blockInputSize :: PU.Size ctx + blockInputSize = PU.size $ blockInputs blk + + lookupReg = flip lookupAbstractRegValue + + -- We maintain the current 'Size' of the context so that we can + -- compute the SSA temp register corresponding to the current + -- statement. + transferSeq :: forall ctx' + . PU.Size ctx' + -> StmtSeq ext blocks ret ctx' + -> PointAbstraction blocks dom ctx' + -> M dom blocks ret (S.Set (Some (BlockID blocks))) + transferSeq sz (ConsStmt _loc stmt ss) = + transferSeq (nextStmtHeight sz stmt) ss . + transferStmt sz stmt + transferSeq _sz (TermStmt _loc term) = transferTerm term + + transferStmt :: forall ctx1 ctx2 + . PU.Size ctx1 + -> Stmt ext ctx1 ctx2 + -> PointAbstraction blocks dom ctx1 + -> PointAbstraction blocks dom ctx2 + transferStmt sz s assignment = + case s of + SetReg (tp :: TypeRepr tp) ex -> + let reg :: Reg (ctx1 ::> tp) tp + reg = Reg (PU.nextIndex sz) + scopedReg = ScopedReg (blockID blk) reg + (assignment', absVal) = interpExpr interp scopedReg tp ex assignment + assignment'' = maybe assignment (joinPointAbstractions dom assignment) assignment' + in extendRegisters absVal assignment'' + + ExtendAssign (estmt :: StmtExtension ext (Reg ctx1) tp) -> + let reg :: Reg (ctx1 ::> tp) tp + reg = Reg (PU.nextIndex sz) + scopedReg = ScopedReg (blockID blk) reg + (assignment', absVal) = interpExt interp scopedReg estmt assignment + assignment'' = maybe assignment (joinPointAbstractions dom assignment) assignment' + in extendRegisters absVal assignment'' + + -- This statement aids in debugging the representation, but + -- should not be a meaningful part of any analysis. For now, + -- skip it in the interpretation. We could add a transfer + -- function for it... + -- + -- Note that this is not used to represent print statements in + -- the language being represented. This is a *crucible* level + -- print. This is actually apparent in the type of Print, + -- which does not modify its context at all. + Print _reg -> assignment + + CallHandle retTp funcHandle argTps actuals -> + let actualsAbstractions = PU.zipWith (\_ act -> lookupReg act assignment) argTps actuals + funcAbstraction = lookupReg funcHandle assignment + (assignment', absVal) = interpCall interp argTps retTp funcHandle funcAbstraction actualsAbstractions assignment + assignment'' = maybe assignment (joinPointAbstractions dom assignment) assignment' + in extendRegisters absVal assignment'' + + -- FIXME: This would actually potentially be nice to + -- capture. We would need to extend the context, + -- though... maybe with a unit type. + Assert _ _ -> assignment + Assume _ _ -> assignment + + ReadGlobal gv -> + let (assignment', absVal) = interpReadGlobal interp gv assignment + assignment'' = maybe assignment (joinPointAbstractions dom assignment) assignment' + in extendRegisters absVal assignment'' + WriteGlobal gv reg -> + let assignment' = interpWriteGlobal interp gv reg assignment + in maybe assignment (joinPointAbstractions dom assignment) assignment' + + FreshConstant{} -> error "transferStmt: FreshConstant not supported" + FreshFloat{} -> error "transferStmt: FreshFloat not supported" + FreshNat{} -> error "transferStmt: FreshNat not supported" + NewEmptyRefCell{} -> error "transferStmt: NewEmptyRefCell not supported" + NewRefCell {} -> error "transferStmt: NewRefCell not supported" + ReadRefCell {} -> error "transferStmt: ReadRefCell not supported" + WriteRefCell {} -> error "transferStmt: WriteRefCell not supported" + DropRefCell {} -> error "transferStmt: DropRefCell not supported" + + -- Transfer a block terminator statement. + transferTerm :: forall ctx' + . TermStmt blocks ret ctx' + -> PointAbstraction blocks dom ctx' + -> M dom blocks ret (S.Set (Some (BlockID blocks))) + transferTerm s assignment = do + -- Save the current point abstraction as the exit point + -- abstraction since we won't be defining any more SSA tmps in + -- this block. + let BlockID srcIdx = blockID blk + isFuncAbstr %= (faExitRegs . ixF srcIdx .~ Ignore (Some assignment)) + + case s of + ErrorStmt {} -> return S.empty + Jump target -> transferJump target assignment + Br condReg target1 target2 -> do + let condAbst = lookupReg condReg assignment + (d1, d2) = interpBr interp condReg condAbst target1 target2 assignment + d1' = maybe assignment (joinPointAbstractions dom assignment) d1 + d2' = maybe assignment (joinPointAbstractions dom assignment) d2 + s1 <- transferJump target1 d1' + s2 <- transferJump target2 d2' + return (S.union s1 s2) + MaybeBranch tp mreg swTarget jmpTarget -> do + let condAbst = lookupReg mreg assignment + (d1, mAbstraction, d2) = interpMaybe interp tp mreg condAbst assignment + d1' = maybe assignment (joinPointAbstractions dom assignment) d1 + d2' = maybe assignment (joinPointAbstractions dom assignment) d2 + s1 <- transferSwitch swTarget mAbstraction d1' + s2 <- transferJump jmpTarget d2' + return (S.union s1 s2) + Return reg -> do + let absVal = lookupReg reg assignment + isRetAbstr %= domJoin dom absVal + return S.empty + + TailCall fn callArgs actuals -> do + let argAbstractions = PU.zipWith (\_tp act -> lookupReg act assignment) callArgs actuals + callee = lookupReg fn assignment + (_assignment', absVal) = interpCall interp callArgs retRepr fn callee argAbstractions assignment + -- assignment'' = maybe assignment (joinPointAbstractions dom assignment) assignment' + + -- We don't really have a place to put a modified assignment + -- here, which is interesting. There is no next block... + isRetAbstr %= domJoin dom absVal + return S.empty + + VariantElim {} -> error "transferTerm: VariantElim terminator not supported" + + + transferJump :: forall ctx' + . JumpTarget blocks ctx' + -> PointAbstraction blocks dom ctx' + -> M dom blocks ret (S.Set (Some (BlockID blocks))) + transferJump (JumpTarget target argsTps actuals) assignment = do + let blockAbstr0 = assignment { _paRegisters = PU.zipWith (\_tp act -> lookupReg act assignment) argsTps actuals + , _paRegisterRefs = PU.zipWith (\_tp act -> lookupRegRefs act assignment) argsTps actuals + } + transferTarget target blockAbstr0 + + transferSwitch :: forall ctx' tp + . SwitchTarget blocks ctx' tp + -> dom tp + -> PointAbstraction blocks dom ctx' + -> M dom blocks ret (S.Set (Some (BlockID blocks))) + transferSwitch (SwitchTarget target argTps actuals) domVal assignment = do + let argRegAbstractions = PU.zipWith (\_ act -> lookupReg act assignment) argTps actuals + argRegRefAbstractions = PU.zipWith (\_ act -> lookupRegRefs act assignment) argTps actuals + blockAbstr0 = assignment { _paRegisters = PU.extend argRegAbstractions domVal + , _paRegisterRefs = PU.extend argRegRefAbstractions emptyRefSet + } + transferTarget target blockAbstr0 + + -- Return the singleton set containing the target block if we + -- haven't converged yet on the current block, and otherwise + -- return an empty set while updating the function abstraction for + -- the current block. + transferTarget :: forall ctx' + . BlockID blocks ctx' + -> PointAbstraction blocks dom ctx' + -> M dom blocks ret (S.Set (Some (BlockID blocks))) + transferTarget target@(BlockID idx) assignment = do + old <- lookupAssignment idx + haveVisited <- isVisited target + let new = joinPointAbstractions dom old assignment + case haveVisited && equalPointAbstractions dom old new of + True -> return S.empty + False -> do + markVisited target + isFuncAbstr %= (faEntryRegs . ixF idx .~ new) + return (S.singleton (Some target)) + +markVisited :: BlockID blocks ctx -> M dom blocks ret () +markVisited bid = do + processedOnce %= S.insert (Some bid) + +isVisited :: BlockID blocks ctx -> M dom blocks ret Bool +isVisited bid = do + s <- St.gets _processedOnce + return (Some bid `S.member` s) + +-- | Compute a fixed point via abstract interpretation over a control +-- flow graph ('CFG') given 1) an interpretation + domain, 2) initial +-- assignments of domain values to global variables, and 3) initial +-- assignments of domain values to function arguments. +-- +-- This is an intraprocedural analysis. To handle function calls, the +-- transfer function for call statements must know how to supply +-- summaries or compute an appropriate conservative approximation. +-- +-- There are two results from the fixed point computation: +-- +-- 1) For each block in the CFG, the abstraction computed at the *entry* to the block +-- +-- 2) For each block in the CFG, the abstraction computed at the +-- *exit* from the block. The 'PU.Assignment' for these "exit" +-- abstractions ignores the @ctx@ index on the blocks, since that +-- context is for *entry* to the blocks. +-- +-- 3) The final abstract value for the value returned by the function +forwardFixpoint' :: forall ext dom blocks ret init + . Domain dom + -- ^ The domain of abstract values + -> Interpretation ext dom + -- ^ The transfer functions for each statement type + -> CFG ext blocks init ret + -- ^ The function to analyze + -> PM.MapF GlobalVar dom + -- ^ Assignments of abstract values to global variables at the function start + -> PU.Assignment dom init + -- ^ Assignments of abstract values to the function arguments + -> ( PU.Assignment (PointAbstraction blocks dom) blocks + , PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks + , dom ret ) +forwardFixpoint' dom interp cfg globals0 assignment0 = + let BlockID idx = cfgEntryBlockID cfg + pa0 = PointAbstraction { _paGlobals = globals0 + , _paRegisters = assignment0 + , _paRefs = PM.empty + , _paRegisterRefs = PU.fmapFC (const emptyRefSet) assignment0 + } + freshAssignment :: PU.Index blocks ctx -> PointAbstraction blocks dom ctx + freshAssignment i = + PointAbstraction { _paRegisters = PU.fmapFC (const (domBottom dom)) (blockInputs (getBlock (BlockID i) (cfgBlockMap cfg))) + , _paRegisterRefs = PU.fmapFC (const emptyRefSet) (blockInputs (getBlock (BlockID i) (cfgBlockMap cfg))) + , _paGlobals = PM.empty + , _paRefs = PM.empty + } + emptyFreshAssignment :: PU.Index blocks ctx -> Ignore (Some (PointAbstraction blocks dom)) ctx + emptyFreshAssignment _i = + Ignore (Some (PointAbstraction { _paRegisters = PU.empty + , _paGlobals = PM.empty + , _paRefs = PM.empty + , _paRegisterRefs = PU.empty + })) + s0 = IterationState { _isRetAbstr = domBottom dom + , _isFuncAbstr = + FunctionAbstraction { _faEntryRegs = + PU.generate (PU.size (cfgBlockMap cfg)) freshAssignment + & ixF idx .~ pa0 + , _faExitRegs = PU.generate (PU.size (cfgBlockMap cfg)) emptyFreshAssignment + , _faRet = domBottom dom + } + , _processedOnce = S.empty + } + iterStrat = iterationStrategy dom + abstr' = St.execState (runM (iterStrat interp cfg)) s0 + in ( _faEntryRegs (_isFuncAbstr abstr') + , _faExitRegs (_isFuncAbstr abstr') + , _isRetAbstr abstr' ) + +-- Preserve old interface for now; fix tests later if my generalization is the right one. +forwardFixpoint :: forall ext dom blocks ret init + . Domain dom + -> Interpretation ext dom + -> CFG ext blocks init ret + -> PM.MapF GlobalVar dom + -> PU.Assignment dom init + -> (PU.Assignment (PointAbstraction blocks dom) blocks, dom ret) +forwardFixpoint dom interp cfg globals0 assignment0 = + let (ass, _, ret) = forwardFixpoint' dom interp cfg globals0 assignment0 + in (ass, ret) + +-- | Inspect the 'Domain' definition to determine which iteration +-- strategy the caller requested. +iterationStrategy :: Domain dom -> (Interpretation ext dom -> CFG ext blocks init ret -> M dom blocks ret ()) +iterationStrategy dom = + case domIter dom of + WTOWidening s op -> wtoIteration (Just (WideningStrategy s, WideningOperator op)) dom + WTO -> wtoIteration Nothing dom + Worklist -> worklistIteration dom + +-- | Iterate over blocks using a worklist (i.e., after a block is +-- processed and abstract values change, put the block successors on +-- the worklist). +-- +-- The worklist is actually processed by taking the lowest-numbered +-- block in a set as the next work item. +worklistIteration :: forall ext dom blocks ret init + . Domain dom + -> Interpretation ext dom + -> CFG ext blocks init ret + -> M dom blocks ret () +worklistIteration dom interp cfg = + loop (S.singleton (Some (cfgEntryBlockID cfg))) + where + loop worklist = + case S.minView worklist of + Nothing -> return () + Just (Some target@(BlockID idx), worklist') -> do + assignment <- lookupAssignment idx + visit (getBlock target (cfgBlockMap cfg)) assignment worklist' + + visit :: Block ext blocks ret ctx + -> PointAbstraction blocks dom ctx + -> S.Set (Some (BlockID blocks)) + -> M dom blocks ret () + visit blk startingAssignment worklist' = do + s <- transfer dom interp (cfgReturnType cfg) blk startingAssignment + loop (S.union s worklist') + +-- | Iterate over the blocks in the control flow graph in weak +-- topological order until a fixed point is reached. +-- +-- The weak topological order essentially formalizes the idea of +-- breaking the graph on back edges and putting the result in +-- topological order. The blocks that serve as loop heads are the +-- heads of their respective strongly connected components. Those +-- block heads are suitable locations to apply widening operators +-- (which can be provided to this iterator). +wtoIteration :: forall ext dom blocks ret init + . Maybe (WideningStrategy, WideningOperator dom) + -- ^ An optional widening operator + -> Domain dom + -> Interpretation ext dom + -> CFG ext blocks init ret + -> M dom blocks ret () +wtoIteration mWiden dom interp cfg = loop (cfgWeakTopologicalOrdering cfg) + where + loop [] = return () + loop (Vertex (Some bid@(BlockID idx)) : rest) = do + assignment <- lookupAssignment idx + let blk = getBlock bid (cfgBlockMap cfg) + _ <- transfer dom interp (cfgReturnType cfg) blk assignment + loop rest + loop (SCC (SCCData { wtoHead = hbid, wtoComps = comps }) : rest) = do + processSCC hbid comps 0 + loop rest + + -- Process a single SCC until the input to the head node of the + -- SCC stabilizes. Applies widening if requested. + processSCC (Some hbid@(BlockID idx)) comps iterNum = do + headInput0 <- lookupAssignment idx + -- We process the SCC until the input to the head of the SCC stabilizes + let headBlock = getBlock hbid (cfgBlockMap cfg) + _ <- transfer dom interp (cfgReturnType cfg) headBlock headInput0 + loop comps + headInput1 <- lookupAssignment idx + case equalPointAbstractions dom headInput0 headInput1 of + True -> return () + False -> do + case mWiden of + -- TODO(conathan): figure out if we need to do something + -- here with 'faExitRegs'? + Just (WideningStrategy strat, WideningOperator widen) + | strat iterNum -> do + -- TODO: is unionRefSets the right thing below? + let headInputW = zipPAWith widen unionRefSets headInput0 headInput1 + isFuncAbstr %= (faEntryRegs . ixF idx .~ headInputW) + _ -> return () + processSCC (Some hbid) comps (iterNum + 1) + +lookupAssignment :: forall dom blocks ret tp + . PU.Index blocks tp + -> M dom blocks ret (PointAbstraction blocks dom tp) +lookupAssignment idx = do + abstr <- St.get + return ((abstr ^. isFuncAbstr . faEntryRegs) PU.! idx) + +lookupRegRefs :: Reg ctx tp -> PointAbstraction blocks dom ctx -> RefSet blocks tp +lookupRegRefs reg assignment = (assignment ^. paRegisterRefs) PU.! regIndex reg + +-- | Turn a non paramaterized type into a parameterized type. +-- +-- For when you want to use a @parameterized-utils@ style data +-- structure with a type that doesn't have a parameter. +-- +-- The same definition as 'Control.Applicative.Const', but with a +-- different 'Show' instance. +newtype Ignore a (b::k) = Ignore { _ignoreOut :: a } + deriving (Eq, Ord) + +instance Show a => Show (Ignore a tp) where + show (Ignore x) = show x + +instance Show a => ShowF (Ignore a) + +-- Lenses + +paGlobals :: (Functor f) + => (PM.MapF GlobalVar dom -> f (PM.MapF GlobalVar dom)) + -> PointAbstraction blocks dom ctx + -> f (PointAbstraction blocks dom ctx) +paGlobals f pa = (\a -> pa { _paGlobals = a }) <$> f (_paGlobals pa) + +paRegisters :: (Functor f) + => (PU.Assignment dom ctx -> f (PU.Assignment dom ctx)) + -> PointAbstraction blocks dom ctx + -> f (PointAbstraction blocks dom ctx) +paRegisters f pa = (\a -> pa { _paRegisters = a }) <$> f (_paRegisters pa) + +paRegisterRefs :: (Functor f) + => (PU.Assignment (RefSet blocks) ctx -> f (PU.Assignment (RefSet blocks) ctx)) + -> PointAbstraction blocks dom ctx + -> f (PointAbstraction blocks dom ctx) +paRegisterRefs f pa = (\a -> pa { _paRegisterRefs = a }) <$> f (_paRegisterRefs pa) + +paRefs :: (Functor f) + => (PM.MapF (RefStmtId blocks) dom -> f (PM.MapF (RefStmtId blocks) dom)) + -> PointAbstraction blocks dom ctx + -> f (PointAbstraction blocks dom ctx) +paRefs f pa = (\a -> pa { _paRefs = a }) <$> f (_paRefs pa) + +faEntryRegs :: (Functor f) + => (PU.Assignment (PointAbstraction blocks dom) blocks -> f (PU.Assignment (PointAbstraction blocks dom) blocks)) + -> FunctionAbstraction dom blocks ret + -> f (FunctionAbstraction dom blocks ret) +faEntryRegs f fa = (\a -> fa { _faEntryRegs = a }) <$> f (_faEntryRegs fa) + +faExitRegs :: (Functor f) + => (PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks -> f (PU.Assignment (Ignore (Some (PointAbstraction blocks dom))) blocks)) + -> FunctionAbstraction dom blocks ret + -> f (FunctionAbstraction dom blocks ret) +faExitRegs f fa = (\a -> fa { _faExitRegs = a }) <$> f (_faExitRegs fa) + +isFuncAbstr :: (Functor f) + => (FunctionAbstraction dom blocks ret -> f (FunctionAbstraction dom blocks ret)) + -> IterationState dom blocks ret + -> f (IterationState dom blocks ret) +isFuncAbstr f is = (\a -> is { _isFuncAbstr = a }) <$> f (_isFuncAbstr is) + +isRetAbstr :: (Functor f) => (dom ret -> f (dom ret)) -> IterationState dom blocks ret -> f (IterationState dom blocks ret) +isRetAbstr f is = (\a -> is { _isRetAbstr = a }) <$> f (_isRetAbstr is) + +processedOnce :: (Functor f) + => (S.Set (Some (BlockID blocks)) -> f (S.Set (Some (BlockID blocks)))) + -> IterationState dom blocks ret + -> f (IterationState dom blocks ret) +processedOnce f is = (\a -> is { _processedOnce = a}) <$> f (_processedOnce is) + +-- $pointed +-- +-- The 'Pointed' type is a wrapper around another 'Domain' that +-- provides distinguished 'Top' and 'Bottom' elements. Use of this +-- type is never required (domains can always define their own top and +-- bottom), but this1 wrapper can save some boring boilerplate. + +-- | The Pointed wrapper that adds Top and Bottom elements +data Pointed dom (tp :: CrucibleType) where + Top :: Pointed a tp + Pointed :: dom tp -> Pointed dom tp + Bottom :: Pointed dom tp + +deriving instance (Eq (dom tp)) => Eq (Pointed dom tp) + +instance ShowF dom => Show (Pointed dom tp) where + show Top = "Top" + show Bottom = "Bottom" + show (Pointed p) = showF p + +instance ShowF dom => ShowF (Pointed dom) + +-- | Construct a 'Pointed' 'Domain' from a pointed join function and +-- an equality test. +pointed :: (forall tp . dom tp -> dom tp -> Pointed dom tp) + -- ^ Join of contained domain elements + -> (forall tp . dom tp -> dom tp -> Bool) + -- ^ Equality for domain elements + -> IterationStrategy (Pointed dom) + -> Domain (Pointed dom) +pointed j eq iterStrat = + Domain { domTop = Top + , domBottom = Bottom + , domJoin = pointedJoin j + , domEq = pointedEq eq + -- TODO(conathan): test faExitRegs computation with WTO + -- strategy. It was hardcoded to 'WTO' here before conathan + -- added block-exit point abstractions. + , domIter = iterStrat + } + + where + pointedJoin _ Top _ = Top + pointedJoin _ _ Top = Top + pointedJoin _ Bottom a = a + pointedJoin _ a Bottom = a + pointedJoin j' (Pointed p1) (Pointed p2) = j' p1 p2 + + pointedEq _ Top Top = True + pointedEq _ Bottom Bottom = True + pointedEq eq' (Pointed p1) (Pointed p2) = eq' p1 p2 + pointedEq _ _ _ = False diff --git a/src/Lang/Crucible/Analysis/Fixpoint/Components.hs b/src/Lang/Crucible/Analysis/Fixpoint/Components.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/Fixpoint/Components.hs @@ -0,0 +1,259 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Analysis.Fixpoint.Components +-- Description : Compute weak topological ordering of CFG +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- Maintainer : Tristan Ravitch +-- Stability : provisional +-- +-- Compute a weak topological ordering over a control flow graph using +-- Bourdoncle's algorithm (See Note [Bourdoncle Components]). +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module Lang.Crucible.Analysis.Fixpoint.Components ( + weakTopologicalOrdering, + WTOComponent(..), + SCC(..), + -- * Special cases + cfgWeakTopologicalOrdering, + cfgSuccessors, + cfgStart + ) where + +import Control.Applicative +import Control.Monad ( when, void ) +import qualified Control.Monad.State.Strict as St +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.Traversable as T + +import Prelude + +import Data.Parameterized.Some (Some(Some)) +import Lang.Crucible.CFG.Core (CFG, BlockID) +import qualified Lang.Crucible.CFG.Core as CFG + +-- | Compute a weak topological ordering over a control flow graph. +-- +-- Weak topological orderings provide an efficient iteration order for +-- chaotic iterations in abstract interpretation and dataflow analysis. +weakTopologicalOrdering :: (Ord n) => (n -> [n]) -> n -> [WTOComponent n] +weakTopologicalOrdering successors start = + wtoPartition (St.execState (runM (visit start)) s0) + where + s0 = WTOState { wtoSuccessors = successors + , wtoPartition = [] + , wtoStack = [] + , wtoLabelSrc = unlabeled + , wtoLabels = M.empty + } + +data WTOComponent n = SCC (SCC n) + | Vertex n + deriving (Functor, F.Foldable, T.Traversable, Show) + +data SCC n = SCCData { wtoHead :: n + , wtoComps :: [WTOComponent n] + } + deriving (Functor, F.Foldable, T.Traversable, Show) + +-- | Useful for creating a first argument to 'weakTopologicalOrdering'. See +-- also 'cfgWeakTopologicalOrdering'. +cfgSuccessors :: + CFG ext blocks init ret -> + Some (BlockID blocks) -> [Some (BlockID blocks)] +cfgSuccessors cfg = \(Some bid) -> CFG.nextBlocks (CFG.getBlock bid bm) where + bm = CFG.cfgBlockMap cfg + +-- | Useful for creating a second argument to 'weakTopologicalOrdering'. See +-- also 'cfgWeakTopologicalOrdering'. +cfgStart :: CFG ext blocks init ret -> Some (BlockID blocks) +cfgStart cfg = Some (CFG.cfgEntryBlockID cfg) + +-- | Compute a weak topological order for the CFG. +cfgWeakTopologicalOrdering :: + CFG ext blocks init ret -> + [WTOComponent (Some (BlockID blocks))] +cfgWeakTopologicalOrdering cfg = weakTopologicalOrdering (cfgSuccessors cfg) (cfgStart cfg) + +visit :: (Ord n) => n -> M n Label +visit v = do + push v + cn <- labelVertex v + (leastLabel, isLoop) <- visitSuccessors v cn + cn' <- lookupLabel v + -- We only create a component if this vertex is the head of its + -- strongly-connected component (i.e., its label is the same as the + -- minimum label in its SCC, returned from visitSuccessors). If so, + -- we make a new component (which may be a singleton if the vertex + -- is not in a loop). + when (cn' == leastLabel) $ do + markDone v + -- Note that we always have to pop, but we might only use the + -- result if there was a loop + pop >>= \case + Just elt -> + case isLoop of + False -> + -- If there is no loop, add a singleton vertex to the partition + addComponent (Vertex v) + True -> do + -- Otherwise, unwind the stack and add a full component + unwindStack elt v + makeComponent v + Nothing -> error "Pop attempted on empty stack (Components:visit)" + -- We return the least label in the strongly-connected component + -- containing this vertex, which is used if we have to unwind back + -- to the SCC head vertex. + return leastLabel + +-- | Unwind the stack until we reach the target node @v@ +unwindStack :: (Ord n) + => n -- ^ Current top of the stack + -> n -- ^ Target element + -> M n () +unwindStack elt v = + case elt /= v of + False -> return () + True -> do + resetLabel elt + pop >>= \case + Just elt' -> unwindStack elt' v + Nothing -> error $ "Emptied stack without finding target element (Components:unwindStack)" + +-- | Make a component with the given head element by visiting +-- everything in the SCC and recursively creating a new partition. +makeComponent :: (Ord n) => n -> M n () +makeComponent v = do + ctx <- St.get + -- Do a recursive traversal with an empty partition + let ctx' = St.execState (runM (go (wtoSuccessors ctx))) (ctx { wtoPartition = [] }) + -- Restore the old partition but with the updated context + St.put (ctx' { wtoPartition = wtoPartition ctx }) + let cmp = SCC $ SCCData { wtoHead = v + , wtoComps = wtoPartition ctx' + } + addComponent cmp + where + go successors = F.forM_ (successors v) $ \s -> do + sl <- lookupLabel s + when (sl == unlabeled) $ do + void (visit s) + +-- | Visit successors of a node and find: +-- +-- 1) The minimum label number of any reachable (indirect) successor +-- and 2) If the node is in a loop +visitSuccessors :: (Ord n) => n -> Label -> M n (Label, Bool) +visitSuccessors v leastLabel0 = do + sucs <- St.gets wtoSuccessors + F.foldlM go (leastLabel0, False) (sucs v) + where + go acc@(leastLabel, _) successor = do + scn <- lookupLabel successor + minScn <- case scn == unlabeled of + True -> visit successor + False -> return scn + case minScn <= leastLabel of + True -> return (minScn, True) + False -> return acc + +-- | Assign a label to a vertex. +-- +-- This generates the next available label and assigns it to the +-- vertex. Note that labels effectively start at 1, since 0 is used +-- to denote unassigned. The actual labels are never exposed to +-- users, so that isn't a big deal. +labelVertex :: (Ord n) => n -> M n Label +labelVertex v = do + cn <- nextLabel <$> St.gets wtoLabelSrc + St.modify' $ \s -> s { wtoLabelSrc = cn + , wtoLabels = M.insert v cn (wtoLabels s) + } + return cn + +-- | Look up the label of a vertex +lookupLabel :: (Ord n) => n -> M n Label +lookupLabel v = do + lbls <- St.gets wtoLabels + case M.lookup v lbls of + Nothing -> return unlabeled + Just l -> return l + +-- | Mark a vertex as processed by setting its Label to maxBound +markDone :: (Ord n) => n -> M n () +markDone v = + St.modify' $ \s -> s { wtoLabels = M.insert v maxLabel (wtoLabels s) } + +-- | Reset a label on a vertex to the unlabeled state +resetLabel :: (Ord n) => n -> M n () +resetLabel v = + St.modify' $ \s -> s { wtoLabels = M.insert v unlabeled (wtoLabels s) } + +-- | Add a component to the current partition +addComponent :: WTOComponent n -> M n () +addComponent c = + St.modify' $ \s -> s { wtoPartition = c : wtoPartition s } + +push :: n -> M n () +push n = St.modify' $ \s -> s { wtoStack = n : wtoStack s } + +pop :: M n (Maybe n) +pop = do + stk <- St.gets wtoStack + case stk of + [] -> return Nothing + n : rest -> do + St.modify' $ \s -> s { wtoStack = rest } + return (Just n) + +data WTOState n = WTOState { wtoSuccessors :: n -> [n] + -- ^ The successor relation for the control flow graph + , wtoPartition :: [WTOComponent n] + -- ^ The partition we are building up + , wtoStack :: [n] + -- ^ A stack of visited nodes + , wtoLabelSrc :: Label + , wtoLabels :: M.Map n Label + } + +newtype M n a = M { runM :: St.State (WTOState n) a } + deriving (Functor, Monad, St.MonadState (WTOState n), Applicative) + +newtype Label = Label Int + deriving (Eq, Ord, Show) + +nextLabel :: Label -> Label +nextLabel (Label n) = Label (n + 1) + +unlabeled :: Label +unlabeled = Label 0 + +maxLabel :: Label +maxLabel = Label maxBound + +{- Note [Bourdoncle Components] + +Bourdoncle components are a weak topological ordering of graph +components that inform a good ordering for chaotic iteration. The +components also provide a good set of locations to insert widening +operators for abstract interpretation. The formulation was proposed +by Francois Bourdoncle in the paper "Efficient chaotic iteration +strategies with widenings" [1]. + +[1] http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.89.8183&rep=rep1&type=pdf + +The basic idea of Bourdoncle's algorithm is to compute the recursive +strongly-connected components of the control flow graph, sorted into +topological order. It is based on Tarjan's SCC algorithm, except that +it recursively looks for strongly-connected components in each SCC it +finds. + +-} diff --git a/src/Lang/Crucible/Analysis/ForwardDataflow.hs b/src/Lang/Crucible/Analysis/ForwardDataflow.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/ForwardDataflow.hs @@ -0,0 +1,309 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Analysis.ForwardDataflow +-- Description : Forward dataflow analysis framework based on Kildall's algorithm +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module defines a generic framework for forward dataflow analysis, +-- with some additional control-flow data on the side. +-- +-- We calculate a fixpoint of a given analysis via the straightforward +-- method of iterating the transfer function until no more updates occur. +-- +-- Our current method for doing this is quite naive, and more efficient +-- methods exist. +------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Lang.Crucible.Analysis.ForwardDataflow +{-# DEPRECATED "Lang.Crucible.Analysis.Fixpoint is a better implementation of these ideas" #-} +where + +import Control.Lens +import Control.Monad.State.Strict +import Data.Kind +import Data.Parameterized.Context ( Assignment ) +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.TraversableFC +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (foldr) +import Prettyprinter + + +import Lang.Crucible.Types +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Expr + +import qualified Debug.Trace as Debug + +----------------------- +data SymDom = Dead | Symbolic | Concrete + deriving (Eq, Ord, Show) + +symbolicResults + :: IsSyntaxExtension ext + => CFG ext blocks init ret + -- -> Assignment (Ignore SymDom) init + -> String + -- -> (Assignment (KildallPair (Assignment (Ignore SymDom)) SymDom) blocks, Ignore SymDom ret, SymDom) +symbolicResults cfg = show $ kildall_forward symbolicAnalysis cfg (begin, Concrete) + where sz = Ctx.size (blockInputs (getBlock (cfgEntryBlockID cfg) (cfgBlockMap cfg))) + begin = Ctx.generate sz (\_ -> Ignore Symbolic) + + +symlub :: SymDom -> SymDom -> SymDom +symlub Dead x = x +symlub x Dead = x +symlub Symbolic _ = Symbolic +symlub _ Symbolic = Symbolic +symlub Concrete Concrete = Concrete + +sym_reg_transfer :: Reg ctx tp -> Assignment (Ignore SymDom) ctx -> SymDom +sym_reg_transfer reg asgn = ignoreOut $ asgn Ctx.! (regIndex reg) + +sym_expr_transfer :: IsSyntaxExtension ext => Expr ext ctx tp -> Assignment (Ignore SymDom) ctx -> SymDom +sym_expr_transfer (App a) asgn + = foldApp (\r z -> symlub z $ sym_reg_transfer r asgn) Dead a + +-- FIXME this whole shabang is bogus, and should be replace by something that works... +-- we assume every function other than "matlabFunctionHandle" returns a symbolic +-- output, but does not have control flow that depends on symbolic data... +sym_call_transfer + :: CtxRepr args + -> TypeRepr ret + -> Reg ctx (FunctionHandleType args ret) + -> Ignore SymDom (FunctionHandleType args ret) + -> Assignment a args + -> Ignore SymDom ret +sym_call_transfer _ _ ex _ _ + = Debug.trace (show $ pretty ex) $ Ignore Symbolic + +symbolicAnalysis :: IsSyntaxExtension ext => KildallForward ext blocks (Ignore SymDom) SymDom +symbolicAnalysis = + KildallForward + { kfwd_lub = \(Ignore x) (Ignore y) -> Ignore (symlub x y) + , kfwd_bot = Ignore Dead + , kfwd_club = symlub + , kfwd_cbot = Dead + , kfwd_same = \(Ignore x) (Ignore y) -> x == y + , kfwd_csame = \x y -> x == y + , kfwd_br = \_ (Ignore x) y -> let z = symlub x y in (z, z) + , kfwd_maybe = \_ _ (Ignore x) y -> let z = symlub x y in (z, Ignore x, z) + , kfwd_reg = \_ ex asgn -> Ignore $ sym_reg_transfer ex asgn + , kfwd_expr = \_ ex asgn -> Ignore $ sym_expr_transfer ex asgn + , kfwd_call = sym_call_transfer + , kfwd_rdglobal = \_ -> Ignore Symbolic + -- FIXME, here we make the totally pessimistic assumption + -- that every global variable read is symbolic + , kfwd_onentry = \_ x -> x + } + +------------------- + +data KildallPair (a::k -> Type) (c :: Type) (tp::k) = KP (a tp) c + +instance (ShowF a, Show c) => Show (KildallPair a c tp) where + show (KP x y) = "(" ++ showF x ++ ", " ++ show y ++ ")" + +instance (ShowF a, Show c) => ShowF (KildallPair a c) + +newtype Ignore a (b::k) = Ignore { ignoreOut :: a } + deriving (Eq, Ord) + +instance Show a => Show (Ignore a tp) where + show (Ignore x) = show x + +instance Show a => ShowF (Ignore a) + + +data KildallForward ext blocks (a :: CrucibleType -> Type) c + = KildallForward + { kfwd_lub :: forall tp. a tp -> a tp -> a tp + , kfwd_bot :: forall tp. a tp + , kfwd_club :: c -> c -> c + , kfwd_cbot :: c + , kfwd_same :: forall tp. a tp -> a tp -> Bool + , kfwd_csame :: c -> c -> Bool + , kfwd_br :: forall ctx. Reg ctx BoolType -> a BoolType -> c -> (c, c) + , kfwd_maybe :: forall ctx tp. TypeRepr tp -> Reg ctx (MaybeType tp) -> a (MaybeType tp) -> c -> (c, a tp, c) + , kfwd_reg :: !(forall ctx tp. TypeRepr tp -> Reg ctx tp -> Assignment a ctx -> a tp) + , kfwd_expr :: !(forall ctx tp. TypeRepr tp -> Expr ext ctx tp -> Assignment a ctx -> a tp) + , kfwd_call :: forall ctx args ret. CtxRepr args + -> TypeRepr ret + -> Reg ctx (FunctionHandleType args ret) + -> a (FunctionHandleType args ret) + -> Assignment a args + -> a ret + , kfwd_rdglobal :: forall tp. GlobalVar tp -> a tp + , kfwd_onentry :: forall ctx. BlockID blocks ctx -> (Assignment a ctx, c) -> (Assignment a ctx, c) + } + +kildall_transfer + :: forall ext a c blocks ret ctx + . KildallForward ext blocks a c + -> TypeRepr ret + -> Block ext blocks ret ctx + -> (Assignment a ctx, c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) +kildall_transfer analysis retRepr blk = transfer_seq (_blockStmts blk) + where transfer_seq :: forall ctx' + . StmtSeq ext blocks ret ctx' + -> (Assignment a ctx', c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) + + transfer_seq (ConsStmt _loc stmt ss) x = transfer_seq ss (transfer_stmt stmt x) + transfer_seq (TermStmt _loc term) x = transfer_term term x + + transfer_stmt :: forall ctx1 ctx2. Stmt ext ctx1 ctx2 -> (Assignment a ctx1, c) -> (Assignment a ctx2, c) + transfer_stmt (SetReg tp ex) (asgn, c) = (Ctx.extend asgn (kfwd_expr analysis tp ex asgn), c) + transfer_stmt (CallHandle rettp ex argstp actuals) (asgn, c) = + let xs = Ctx.zipWith (\tp act -> kfwd_reg analysis tp act asgn) argstp actuals + ex_sh = kfwd_reg analysis (FunctionHandleRepr argstp rettp) ex asgn + a' = kfwd_call analysis argstp rettp ex ex_sh xs + in (Ctx.extend asgn a', c) + transfer_stmt (Print _) asgn = asgn + transfer_stmt (ReadGlobal gv) (asgn, c) = (Ctx.extend asgn (kfwd_rdglobal analysis gv), c) + transfer_stmt FreshConstant{} _ = error "forward dataflow: fresh constant!" + transfer_stmt FreshFloat{} _ = error "forward dataflow: fresh float!" + transfer_stmt FreshNat{} _ = error "forward dataflow: fresh nat!" + transfer_stmt ExtendAssign{} _ = error "extension statement!" + transfer_stmt NewRefCell{} _ = error "forward dataflow: reference cell!" + transfer_stmt NewEmptyRefCell{} _ = error "forward dataflow: reference cell!" + transfer_stmt ReadRefCell{} _ = error "forward dataflow: reference cell!" + transfer_stmt WriteRefCell{} _ = error "forward dataflow: reference cell!" + transfer_stmt DropRefCell{} _ = error "forward dataflow: reference cell!" + transfer_stmt (WriteGlobal _ _) asgnc = asgnc -- FIXME? need to check something here, perhaps? + transfer_stmt (Assert _ _) asgnc = asgnc -- FIXME? is it useful to remember assertions some way? + transfer_stmt (Assume _ _) asgnc = asgnc -- FIXME? is it useful to remember assertions some way? + + transfer_term :: forall ctx' + . TermStmt blocks ret ctx' + -> (Assignment a ctx', c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) + + transfer_term (ErrorStmt _) _ = return Set.empty + + transfer_term (Jump tgt) x = transfer_jump tgt x + + transfer_term (Br ex tgt1 tgt2) (asgn,c) = do + let a = kfwd_reg analysis knownRepr ex asgn + let (c1,c2) = kfwd_br analysis ex a c + s1 <- transfer_jump tgt1 (asgn,c1) + s2 <- transfer_jump tgt2 (asgn,c2) + return (Set.union s1 s2) + + transfer_term (Return ex) (asgn, c) = do + let a = kfwd_reg analysis retRepr ex asgn + modify (\ (x,r,rc) -> (x, kfwd_lub analysis r a, kfwd_club analysis rc c)) + return Set.empty + + transfer_term (TailCall fn callargs actuals) (asgn, c) = do + let xs = Ctx.zipWith (\tp act -> kfwd_reg analysis tp act asgn) callargs actuals + let fn_sh = kfwd_reg analysis (FunctionHandleRepr callargs retRepr) fn asgn + let a' = kfwd_call analysis callargs retRepr fn fn_sh xs + modify (\ (x,r,rc) -> (x, kfwd_lub analysis r a', kfwd_club analysis rc c)) + return Set.empty + + transfer_term (MaybeBranch tp ex swtgt jmptgt) (asgn, c) = do + let a = kfwd_reg analysis (MaybeRepr tp) ex asgn + let (c1, a1, c2) = kfwd_maybe analysis tp ex a c + s1 <- transfer_switch swtgt a1 (asgn, c1) + s2 <- transfer_jump jmptgt (asgn, c2) + return (Set.union s1 s2) + + transfer_term (VariantElim _ctx _ex _switch) (_asgn, _c) = do + error "FIXME: transfer_term for VariantElim not implemented" + + transfer_switch :: forall ctx' tp + . SwitchTarget blocks ctx' tp + -> a tp + -> (Assignment a ctx', c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) + transfer_switch (SwitchTarget tgt argstp actuals) a1 (asgn, c) = do + let xs = Ctx.zipWith (\tp act -> kfwd_reg analysis tp act asgn) argstp actuals + let xs' = Ctx.extend xs a1 + transfer_target tgt (xs', c) + + transfer_jump :: forall ctx' + . JumpTarget blocks ctx' + -> (Assignment a ctx', c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) + + transfer_jump (JumpTarget tgt argstp actuals) (asgn, c) = do + let xs = Ctx.zipWith (\tp act -> kfwd_reg analysis tp act asgn) argstp actuals + transfer_target tgt (xs, c) + + transfer_target :: forall ctx' + . BlockID blocks ctx' + -> (Assignment a ctx', c) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) (Set (Some (BlockID blocks))) + transfer_target tgt@(BlockID idx) (asgn, c) = do + (x,r,rc) <- get + let KP old oldc = x Ctx.! idx + let new = Ctx.zipWith (\a b -> kfwd_lub analysis a b) old asgn + let zipsame = Ctx.zipWith (\a b -> Ignore $ kfwd_same analysis a b) old new + let samex = foldlFC (\a (Ignore b) -> a && b) True zipsame + let newc = kfwd_club analysis c oldc + let same = samex && kfwd_csame analysis oldc newc + if same + then return Set.empty + else do put (x & ixF idx .~ KP new newc, r, rc) + return (Set.singleton (Some tgt)) + + + +kildall_forward + :: forall ext a c blocks ret init + . KildallForward ext blocks a c + -> CFG ext blocks init ret + -> (Assignment a init, c) + -> (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) +kildall_forward analysis cfg (asgn0,c0) = + let initblk@(BlockID idx) = cfgEntryBlockID cfg + + freshAsgn :: Ctx.Index blocks ctx -> Assignment a ctx + freshAsgn i = fmapFC (\_ -> kfwd_bot analysis) + (blockInputs (getBlock (BlockID i) (cfgBlockMap cfg))) + + in execState (loop (Set.singleton (Some initblk))) + ( Ctx.generate (Ctx.size (cfgBlockMap cfg)) $ \i -> + case testEquality i idx of + Just Refl -> KP asgn0 c0 + Nothing -> KP (freshAsgn i) (kfwd_cbot analysis) + , kfwd_bot analysis + , kfwd_cbot analysis + ) + + where visit :: Block ext blocks ret ctx + -> (Assignment a ctx, c) + -> Set (Some (BlockID blocks)) + -> State (Assignment (KildallPair (Assignment a) c) blocks, a ret, c) () + visit blk start worklist = do + s <- kildall_transfer analysis (cfgReturnType cfg) blk start + loop (Set.union s worklist) + + loop worklist = + case Set.minView worklist of + Nothing -> return () + Just (Some tgt@(BlockID idx), worklist') -> + do (x,_,_) <- get + let (KP a c) = x Ctx.! idx + (a',c') = kfwd_onentry analysis tgt (a,c) + visit (getBlock tgt (cfgBlockMap cfg)) (a',c') worklist' diff --git a/src/Lang/Crucible/Analysis/Postdom.hs b/src/Lang/Crucible/Analysis/Postdom.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/Postdom.hs @@ -0,0 +1,182 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Analysis.Postdom +-- Description : Populates postdominator entries in CFG blocks. +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides a method for populating the postdominator fields +-- in blocks of a Core SSA-form CFG. +------------------------------------------------------------------------ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Lang.Crucible.Analysis.Postdom + ( postdomInfo + , breakpointPostdomInfo + , validatePostdom + ) where + +import Control.Monad.State +import qualified Data.Bimap as Bimap +import Data.Functor.Const +import qualified Data.Graph.Inductive as G +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.TraversableFC +import qualified Data.Set as Set + +import Lang.Crucible.CFG.Core + +-- | Convert a block ID to a node +toNode :: BlockID blocks ctx -> G.Node +toNode (BlockID b) = 1 + Ctx.indexVal b + +-- | Create +reverseEdge :: Int -> Block ext blocks ret ctx -> G.LEdge () +reverseEdge d b = (d, toNode (blockID b), ()) + +-- | For a given block with out edges l, return edges from +-- each block in @l@ to @b@. +inEdges :: Block ext blocks ret ctx -> [G.LEdge ()] +inEdges b = + case withBlockTermStmt b (\_ -> termStmtNextBlocks) of + Nothing -> [reverseEdge 0 b] + Just l -> (\(Some n) -> toNode n `reverseEdge` b) <$> l + +inEdgeGraph :: BlockMap ext blocks ret -> [Some (BlockID blocks)] -> G.UGr +inEdgeGraph m breakpointIds = G.mkGraph ((,()) <$> nodes) edges + where nodes = 0 : toListFC (toNode . blockID) m + cfgEdges = foldMapFC inEdges m + breakpointEdges = map (\(Some bid) -> reverseEdge 0 (getBlock bid m)) + breakpointIds + edges = cfgEdges ++ breakpointEdges + +-- | Return subgraph of nodes reachable from given node. +reachableSubgraph :: G.Node -> G.UGr -> G.UGr +reachableSubgraph initNode g = G.mkGraph nl el + where reachableNodes = Set.fromList $ G.bfs initNode g + keepNode = (`Set.member` reachableNodes) + nl = filter (\(n,_) -> keepNode n) (G.labNodes g) + + keepEdge (s,e,_) = keepNode s && keepNode e + el = filter keepEdge (G.labEdges g) + +nodeToBlockIDMap :: BlockMap ext blocks ret + -> Map G.Node (Some (BlockID blocks)) +nodeToBlockIDMap = + foldrFC (\b -> Map.insert (toNode (blockID b)) (Some (blockID b))) + Map.empty + +postdomMap :: forall ext blocks ret + . BlockMap ext blocks ret + -> [Some (BlockID blocks)] + -> Map (Some (BlockID blocks)) [Some (BlockID blocks)] +postdomMap m breakpointIds = r + where g0 = inEdgeGraph m breakpointIds + g = reachableSubgraph 0 g0 + + idMap = nodeToBlockIDMap m + f :: Int -> Maybe (Some (BlockID blocks)) + f 0 = Nothing + f i = Map.lookup i idMap + -- Map each block to the postdominator for the block. + r = Map.fromList + [ (pd_id, mapMaybe f l) + | (pd,_:l) <- G.dom g 0 + , pd > 0 + -- Get the post dominator blkID, using a total version of: + -- let Just pd_id = Map.lookup pd idMap + , pd_id <- catMaybes [ Map.lookup pd idMap ] + ] + +postdomAssignment :: forall ext blocks ret + . BlockMap ext blocks ret + -> [Some (BlockID blocks)] + -> CFGPostdom blocks +postdomAssignment m breakpointIds = fmapFC go m + where pd = postdomMap m breakpointIds + go :: Block ext blocks ret c -> Const [Some (BlockID blocks)] c + go b = Const $ fromMaybe [] (Map.lookup (Some (blockID b)) pd) + +-- | Compute posstdom information for CFG. +postdomInfo :: CFG ext b i r -> CFGPostdom b +postdomInfo g = postdomAssignment (cfgBlockMap g) [] + +breakpointPostdomInfo :: CFG ext b i r -> [BreakpointName] -> CFGPostdom b +breakpointPostdomInfo g breakpointNames = postdomAssignment (cfgBlockMap g) $ + mapMaybe (\nm -> Bimap.lookup nm (cfgBreakpoints g)) breakpointNames + +blockEndsWithError :: Block ext blocks ret args -> Bool +blockEndsWithError b = + withBlockTermStmt b $ \_ ts -> + case ts of + ErrorStmt{} -> True + _ -> False + +addErrorIf :: Bool -> String -> State [String] () +addErrorIf True msg = modify $ (msg:) +addErrorIf False _ = return () + +validateTarget :: CFG ext blocks init ret + -> CFGPostdom blocks + -> String + -- ^ Identifier for error. + -> [Some (BlockID blocks)] + -- ^ Postdoms for source block. + -> Some (BlockID blocks) + -- ^ Target + -> State [String] () +validateTarget _ pdInfo src (Some pd:src_postdoms) (Some tgt) + | isJust (testEquality pd tgt) = + addErrorIf (src_postdoms /= tgt_postdoms) $ + "Unexpected postdominators from " ++ src ++ " to " ++ show tgt ++ "." + where Const tgt_postdoms = pdInfo Ctx.! blockIDIndex tgt +validateTarget g pdInfo src src_postdoms (Some tgt) + | blockEndsWithError tgt_block = + return () + | otherwise = do + let tgt_len = length tgt_postdoms + let src_len = length src_postdoms + addErrorIf (tgt_len < src_len) $ + "Unexpected postdominators from " ++ src ++ " to " ++ show tgt ++ "." + let tgt_prefix = drop (tgt_len - src_len) tgt_postdoms + addErrorIf (src_postdoms /= tgt_prefix) $ + "Unexpected postdominators from " ++ src ++ " to " ++ show tgt ++ "." + where tgt_block = getBlock tgt (cfgBlockMap g) + Const tgt_postdoms = pdInfo Ctx.! blockIDIndex tgt + +validatePostdom :: CFG ext blocks init ret + -> CFGPostdom blocks + -> [String] +validatePostdom g pdInfo = flip execState [] $ do + forFC_ (cfgBlockMap g) $ \b -> do + let Const b_pd = pdInfo Ctx.! blockIDIndex (blockID b) + let loc = show (cfgHandle g) ++ show (blockID b) + mapM_ (validateTarget g pdInfo loc b_pd) (nextBlocks b) + + withBlockTermStmt b $ \_ ts -> do + case ts of + Jump tgt -> do + validateTarget g pdInfo loc b_pd (jumpTargetID tgt) + Br _ tgt1 tgt2 -> do + validateTarget g pdInfo loc b_pd (jumpTargetID tgt1) + validateTarget g pdInfo loc b_pd (jumpTargetID tgt2) + MaybeBranch _ _ x y -> do + validateTarget g pdInfo loc b_pd (switchTargetID x) + validateTarget g pdInfo loc b_pd (jumpTargetID y) + VariantElim _ _ s -> do + traverseFC_ (validateTarget g pdInfo loc b_pd . switchTargetID) s + Return{} -> do + addErrorIf (not (null b_pd)) $ + "Expected empty postdom in " ++ loc ++ "." + TailCall{} -> do + addErrorIf (not (null b_pd)) $ + "Expected empty postdom in " ++ loc ++ "." + ErrorStmt{} -> do + addErrorIf (not (null b_pd)) $ + "Expected empty postdom in " ++ loc ++ "." diff --git a/src/Lang/Crucible/Analysis/Reachable.hs b/src/Lang/Crucible/Analysis/Reachable.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Analysis/Reachable.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Analysis.Reachable +-- Description : Compute the reachable subgraph of a CFG +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- Compute reachability on CFG blocks, reduce the CFG to include just +-- the reachable blocks, and remap block labels in the program to point +-- to the new, relabeled blocks. +------------------------------------------------------------------------ + +{-# LANGUAGE ScopedTypeVariables #-} +module Lang.Crucible.Analysis.Reachable + ( reachableCFG + ) where + +import Control.Monad.Identity +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Bimap as Bimap +import Data.Parameterized.Map (MapF) +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.TraversableFC +import qualified Data.Parameterized.Context as Ctx +import Lang.Crucible.CFG.Core + +remapBlockID :: MapF (BlockID b) (BlockID b') -> BlockID b a -> BlockID b' a +remapBlockID m b = + fromMaybe (error $ "Could not remap block " ++ show b) + (MapF.lookup b m) + +remapJumpTarget :: MapF (BlockID b) (BlockID b') + -> JumpTarget b c -> JumpTarget b' c +remapJumpTarget m (JumpTarget x r a) = JumpTarget (remapBlockID m x) r a + +remapSwitchTarget :: MapF (BlockID b) (BlockID b') + -> SwitchTarget b c r -> SwitchTarget b' c r +remapSwitchTarget m (SwitchTarget x r a) = SwitchTarget (remapBlockID m x) r a + + +remapTermStmt :: MapF (BlockID b) (BlockID b') -> TermStmt b ret c -> TermStmt b' ret c +remapTermStmt m ts = + case ts of + Jump jmp -> Jump (remapJumpTarget m jmp) + Br c x y -> Br c (remapJumpTarget m x) (remapJumpTarget m y) + MaybeBranch tp r x y -> MaybeBranch tp r (remapSwitchTarget m x) (remapJumpTarget m y) + VariantElim c r a -> VariantElim c r (fmapFC (remapSwitchTarget m) a) + Return r -> Return r + TailCall f c a -> TailCall f c a + ErrorStmt r -> ErrorStmt r + +remapBlock :: MapF (BlockID b) (BlockID b') + -> BlockID b' ctx + -> Block ext b r ctx + -> Block ext b' r ctx +remapBlock m nm b = + Block { blockID = nm + , blockInputs = blockInputs b + , _blockStmts = + runIdentity $ + stmtSeqTermStmt + (\(l,s) -> Identity (TermStmt l (remapTermStmt m s))) + (_blockStmts b) + } + +mkOldMap :: forall ext b b' r + . Ctx.Assignment (Block ext b r) b' + -> MapF (BlockID b) (BlockID b') +mkOldMap a = Ctx.forIndex (Ctx.size a) f MapF.empty + where f :: MapF (BlockID b) (BlockID b') + -> Ctx.Index b' c + -> MapF (BlockID b) (BlockID b') + f m new_index = MapF.insert (blockID b) (BlockID new_index) m + where b = a Ctx.! new_index + +remapBlockMap :: forall ext b b' ret + . MapF (BlockID b) (BlockID b') + -> Ctx.Assignment (Block ext b ret) b' + -- ^ Map new blocks to old block IDs. + -> BlockMap ext b' ret +remapBlockMap oldToNew newToOld = Ctx.generate (Ctx.size newToOld) $ f + where f :: Ctx.Index b' ctx -> Block ext b' ret ctx + f i = remapBlock oldToNew (BlockID i) (newToOld Ctx.! i) + +exploreReachable :: BlockMap ext blocks ret + -> BlockID blocks init + -> Map (Some (BlockID blocks)) Int +exploreReachable m d = exploreReachable' m [Some d] Map.empty + +exploreReachable' :: BlockMap ext blocks ret + -> [Some (BlockID blocks)] + -> Map (Some (BlockID blocks)) Int + -> Map (Some (BlockID blocks)) Int +exploreReachable' _ [] r = r +exploreReachable' m (Some h:l) r = + case Map.lookup (Some h) r of + Just c -> exploreReachable' m l (Map.insert (Some h) (c+1) r) + Nothing -> do + let b = getBlock h m + exploreReachable' m (nextBlocks b ++ l) (Map.insert (Some h) 1 r) + +insReachable :: BlockMap ext b r + -> Some (Ctx.Assignment (Block ext b r)) + -> Some (BlockID b) + -> Some (Ctx.Assignment (Block ext b r)) +insReachable m (Some a) (Some (BlockID block_id)) = Some $ a Ctx.:> (m Ctx.! block_id) + + + +reachableCFG :: CFG ext blocks init ret -> SomeCFG ext init ret +reachableCFG g = + case foldl (insReachable old_map) (Some Ctx.empty) (Map.keys reachables) of + Some newToOld -> +-- trace ("Size change: " ++ show (Ctx.sizeInt (Ctx.size old_map) - Ctx.sizeInt (Ctx.size new_map))) $ + SomeCFG g' + where oldToNew = mkOldMap newToOld + new_map = remapBlockMap oldToNew newToOld + new_breakpoints = Bimap.mapR (mapSome $ remapBlockID oldToNew) (cfgBreakpoints g) + g' = CFG { cfgHandle = cfgHandle g + , cfgBlockMap = new_map + , cfgEntryBlockID = remapBlockID oldToNew entry_id + , cfgBreakpoints = new_breakpoints + } + where old_map = cfgBlockMap g + entry_id = cfgEntryBlockID g + reachables = exploreReachable old_map entry_id diff --git a/src/Lang/Crucible/Backend.hs b/src/Lang/Crucible/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Backend.hs @@ -0,0 +1,632 @@ +{-| +Module : Lang.Crucible.Backend +Copyright : (c) Galois, Inc 2014-2022 +License : BSD3 +Maintainer : Joe Hendrix + +This module provides an interface that symbolic backends must provide +for interacting with the symbolic simulator. + +Compared to the solver connections provided by What4, Crucible backends provide +a facility for managing an /assumption stack/ (see 'AS.AssumptionStack'). Note +that these backends are layered on top of the 'What4.Expr.Builder.ExprBuilder'; +the solver choice is still up to the user. The +'Lang.Crucible.Backend.Simple.SimpleBackend' is designed to be used with an +offline solver connection, while the +'Lang.Crucible.Backend.Online.OnlineBackend' is designed to be used with an +online solver. + +The 'AS.AssumptionStack' tracks the assumptions that are in scope for each +assertion, accounting for the branching and merging structure of programs. The +symbolic simulator manages the 'AS.AssumptionStack'. After symbolic simulation +completes, the caller should traverse the 'AS.AssumptionStack' (or use +combinators like 'AS.proofGoalsToList') to discharge the resulting proof +obligations with a solver backend. + +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Lang.Crucible.Backend + ( IsSymBackend(..) + , IsSymInterface + , HasSymInterface(..) + , SomeBackend(..) + + -- * Assumption management + , CrucibleAssumption(..) + , CrucibleEvent(..) + , CrucibleAssumptions(..) + , Assumption + , Assertion + , Assumptions + + , concretizeEvents + , ppEvent + , singleEvent + , singleAssumption + , trivialAssumption + , impossibleAssumption + , ppAssumption + , assumptionLoc + , eventLoc + , mergeAssumptions + , assumptionPred + , forgetAssumption + , assumptionsPred + , flattenAssumptions + , assumptionsTopLevelLocs + , ProofObligation + , ProofObligations + , AssumptionState + , assert + + -- ** Reexports + , LabeledPred(..) + , labeledPred + , labeledPredMsg + , AS.AssumptionStack + , AS.FrameIdentifier + , PG.ProofGoal(..) + , PG.Goals(..) + , PG.goalsToList + + -- ** Aborting execution + , AbortExecReason(..) + , abortExecBecause + , ppAbortExecReason + + -- * Utilities + , throwUnsupported + + , addAssertion + , addDurableAssertion + , addAssertionM + , addFailedAssertion + , assertIsInteger + , readPartExpr + , ppProofObligation + , backendOptions + , assertThenAssumeConfigOption + ) where + +import Control.Exception(Exception(..), throwIO) +import Control.Lens ((^.), Traversal, folded) +import Control.Monad +import Control.Monad.IO.Class +import Data.Kind (Type) +import Data.Foldable (toList) +import Data.Functor.Identity +import Data.Functor.Const +import qualified Data.Sequence as Seq +import Data.Sequence (Seq) +import qualified Prettyprinter as PP +import GHC.Stack + +import What4.Concrete +import What4.Config +import What4.Interface +import What4.InterpretedFloatingPoint +import What4.LabeledPred +import What4.Partial +import What4.ProgramLoc +import What4.Expr (GroundValue, GroundValueWrapper(..)) + +import qualified Lang.Crucible.Backend.AssumptionStack as AS +import qualified Lang.Crucible.Backend.ProofGoals as PG +import Lang.Crucible.Simulator.SimError + +-- | This type describes assumptions made at some point during program execution. +data CrucibleAssumption (e :: BaseType -> Type) + = GenericAssumption ProgramLoc String (e BaseBoolType) + -- ^ An unstructured description of the source of an assumption. + + | BranchCondition ProgramLoc (Maybe ProgramLoc) (e BaseBoolType) + -- ^ This arose because we want to explore a specific path. + -- The first location is the location of the branch predicate. + -- The second one is the location of the branch target. + + | AssumingNoError SimError (e BaseBoolType) + -- ^ An assumption justified by a proof of the impossibility of + -- a certain simulator error. + +-- | This type describes events we can track during program execution. +data CrucibleEvent (e :: BaseType -> Type) where + -- | This event describes the creation of a symbolic variable. + CreateVariableEvent :: + ProgramLoc {- ^ location where the variable was created -} -> + String {- ^ user-provided name for the variable -} -> + BaseTypeRepr tp {- ^ type of the variable -} -> + e tp {- ^ the variable expression -} -> + CrucibleEvent e + + -- | This event describes reaching a particular program location. + LocationReachedEvent :: + ProgramLoc -> + CrucibleEvent e + +-- | Pretty print an event +ppEvent :: IsExpr e => CrucibleEvent e -> PP.Doc ann +ppEvent (CreateVariableEvent loc nm _tpr v) = + "create var" PP.<+> PP.pretty nm PP.<+> "=" PP.<+> printSymExpr v PP.<+> "at" PP.<+> PP.pretty (plSourceLoc loc) +ppEvent (LocationReachedEvent loc) = + "reached" PP.<+> PP.pretty (plSourceLoc loc) PP.<+> "in" PP.<+> PP.pretty (plFunction loc) + +-- | Return the program location associated with an event +eventLoc :: CrucibleEvent e -> ProgramLoc +eventLoc (CreateVariableEvent loc _ _ _) = loc +eventLoc (LocationReachedEvent loc) = loc + +-- | Return the program location associated with an assumption +assumptionLoc :: CrucibleAssumption e -> ProgramLoc +assumptionLoc r = + case r of + GenericAssumption l _ _ -> l + BranchCondition l _ _ -> l + AssumingNoError s _ -> simErrorLoc s + +-- | Get the predicate associated with this assumption +assumptionPred :: CrucibleAssumption e -> e BaseBoolType +assumptionPred (AssumingNoError _ p) = p +assumptionPred (BranchCondition _ _ p) = p +assumptionPred (GenericAssumption _ _ p) = p + +-- | If an assumption is clearly impossible, return an abort reason +-- that can be used to unwind the execution of this branch. +impossibleAssumption :: IsExpr e => CrucibleAssumption e -> Maybe AbortExecReason +impossibleAssumption (AssumingNoError err p) + | Just False <- asConstantPred p = Just (AssertionFailure err) +impossibleAssumption (BranchCondition loc _ p) + | Just False <- asConstantPred p = Just (InfeasibleBranch loc) +impossibleAssumption (GenericAssumption loc _ p) + | Just False <- asConstantPred p = Just (InfeasibleBranch loc) +impossibleAssumption _ = Nothing + +forgetAssumption :: CrucibleAssumption e -> CrucibleAssumption (Const ()) +forgetAssumption = runIdentity . traverseAssumption (\_ -> Identity (Const ())) + +traverseAssumption :: Traversal (CrucibleAssumption e) (CrucibleAssumption e') (e BaseBoolType) (e' BaseBoolType) +traverseAssumption f = \case + GenericAssumption loc msg p -> GenericAssumption loc msg <$> f p + BranchCondition l t p -> BranchCondition l t <$> f p + AssumingNoError err p -> AssumingNoError err <$> f p + +-- | This type tracks both logical assumptions and program events +-- that are relevant when evaluating proof obligations arising +-- from simulation. +data CrucibleAssumptions (e :: BaseType -> Type) where + SingleAssumption :: CrucibleAssumption e -> CrucibleAssumptions e + SingleEvent :: CrucibleEvent e -> CrucibleAssumptions e + ManyAssumptions :: Seq (CrucibleAssumptions e) -> CrucibleAssumptions e + MergeAssumptions :: + e BaseBoolType {- ^ branch condition -} -> + CrucibleAssumptions e {- ^ "then" assumptions -} -> + CrucibleAssumptions e {- ^ "else" assumptions -} -> + CrucibleAssumptions e + +instance Semigroup (CrucibleAssumptions e) where + ManyAssumptions xs <> ManyAssumptions ys = ManyAssumptions (xs <> ys) + ManyAssumptions xs <> y = ManyAssumptions (xs Seq.|> y) + x <> ManyAssumptions ys = ManyAssumptions (x Seq.<| ys) + x <> y = ManyAssumptions (Seq.fromList [x,y]) + +instance Monoid (CrucibleAssumptions e) where + mempty = ManyAssumptions mempty + +singleAssumption :: CrucibleAssumption e -> CrucibleAssumptions e +singleAssumption x = SingleAssumption x + +singleEvent :: CrucibleEvent e -> CrucibleAssumptions e +singleEvent x = SingleEvent x + +-- | Collect the program locations of all assumptions and +-- events that did not occur in the context of a symbolic branch. +-- These are locations that every program path represented by +-- this @CrucibleAssumptions@ structure must have passed through. +assumptionsTopLevelLocs :: CrucibleAssumptions e -> [ProgramLoc] +assumptionsTopLevelLocs (SingleEvent e) = [eventLoc e] +assumptionsTopLevelLocs (SingleAssumption a) = [assumptionLoc a] +assumptionsTopLevelLocs (ManyAssumptions as) = concatMap assumptionsTopLevelLocs as +assumptionsTopLevelLocs MergeAssumptions{} = [] + +-- | Compute the logical predicate corresponding to this collection of assumptions. +assumptionsPred :: IsExprBuilder sym => sym -> Assumptions sym -> IO (Pred sym) +assumptionsPred sym (SingleEvent _) = + return (truePred sym) +assumptionsPred _sym (SingleAssumption a) = + return (assumptionPred a) +assumptionsPred sym (ManyAssumptions xs) = + andAllOf sym folded =<< traverse (assumptionsPred sym) xs +assumptionsPred sym (MergeAssumptions c xs ys) = + do xs' <- assumptionsPred sym xs + ys' <- assumptionsPred sym ys + itePred sym c xs' ys' + +traverseEvent :: Applicative m => + (forall tp. e tp -> m (e' tp)) -> + CrucibleEvent e -> m (CrucibleEvent e') +traverseEvent f (CreateVariableEvent loc nm tpr v) = CreateVariableEvent loc nm tpr <$> f v +traverseEvent _ (LocationReachedEvent loc) = pure (LocationReachedEvent loc) + +-- | Given a ground evaluation function, compute a linear, ground-valued +-- sequence of events corresponding to this program run. +concretizeEvents :: + IsExpr e => + (forall tp. e tp -> IO (GroundValue tp)) -> + CrucibleAssumptions e -> + IO [CrucibleEvent GroundValueWrapper] +concretizeEvents f = loop + where + loop (SingleEvent e) = + do e' <- traverseEvent (\v -> GVW <$> f v) e + return [e'] + loop (SingleAssumption _) = return [] + loop (ManyAssumptions as) = concat <$> traverse loop as + loop (MergeAssumptions p xs ys) = + do b <- f p + if b then loop xs else loop ys + +-- | Given a @CrucibleAssumptions@ structure, flatten all the muxed assumptions into +-- a flat sequence of assumptions that have been appropriately weakened. +-- Note, once these assumptions have been flattened, their order might no longer +-- strictly correspond to any concrete program run. +flattenAssumptions :: IsExprBuilder sym => sym -> Assumptions sym -> IO [Assumption sym] +flattenAssumptions sym = loop Nothing + where + loop _mz (SingleEvent _) = return [] + loop mz (SingleAssumption a) = + do a' <- maybe (pure a) (\z -> traverseAssumption (impliesPred sym z) a) mz + if trivialAssumption a' then return [] else return [a'] + loop mz (ManyAssumptions as) = + concat <$> traverse (loop mz) as + loop mz (MergeAssumptions p xs ys) = + do pnot <- notPred sym p + px <- maybe (pure p) (andPred sym p) mz + py <- maybe (pure pnot) (andPred sym pnot) mz + xs' <- loop (Just px) xs + ys' <- loop (Just py) ys + return (xs' <> ys') + +-- | Merge the assumptions collected from the branches of a conditional. +mergeAssumptions :: + IsExprBuilder sym => + sym -> + Pred sym -> + Assumptions sym -> + Assumptions sym -> + IO (Assumptions sym) +mergeAssumptions _sym p thens elses = + return (MergeAssumptions p thens elses) + +type Assertion sym = LabeledPred (Pred sym) SimError +type Assumption sym = CrucibleAssumption (SymExpr sym) +type Assumptions sym = CrucibleAssumptions (SymExpr sym) +type ProofObligation sym = AS.ProofGoal (Assumptions sym) (Assertion sym) +type ProofObligations sym = Maybe (AS.Goals (Assumptions sym) (Assertion sym)) +type AssumptionState sym = PG.GoalCollector (Assumptions sym) (Assertion sym) + +-- | This is used to signal that current execution path is infeasible. +data AbortExecReason = + InfeasibleBranch ProgramLoc + -- ^ We have discovered that the currently-executing + -- branch is infeasible. The given program location + -- describes the point at which infeasibility was discovered. + + | AssertionFailure SimError + -- ^ An assertion concretely failed. + + | VariantOptionsExhausted ProgramLoc + -- ^ We tried all possible cases for a variant, and now we should + -- do something else. + + | EarlyExit ProgramLoc + -- ^ We invoked a function which ends the current thread of execution + -- (e.g., @abort()@ or @exit(1)@). + + deriving Show + +instance Exception AbortExecReason + + +ppAbortExecReason :: AbortExecReason -> PP.Doc ann +ppAbortExecReason e = + case e of + InfeasibleBranch l -> ppLocated l "Executing branch was discovered to be infeasible." + AssertionFailure err -> + PP.vcat + [ "Abort due to assertion failure:" + , PP.indent 2 (ppSimError err) + ] + VariantOptionsExhausted l -> ppLocated l "Variant options exhausted." + EarlyExit l -> ppLocated l "Program exited early." + +ppAssumption :: (forall tp. e tp -> PP.Doc ann) -> CrucibleAssumption e -> PP.Doc ann +ppAssumption ppDoc e = + case e of + GenericAssumption l msg p -> + PP.vsep [ ppLocated l (PP.pretty msg) + , ppDoc p + ] + BranchCondition l Nothing p -> + PP.vsep [ "The branch in" PP.<+> ppFn l PP.<+> "at" PP.<+> ppLoc l + , ppDoc p + ] + BranchCondition l (Just t) p -> + PP.vsep [ "The branch in" PP.<+> ppFn l PP.<+> "from" PP.<+> ppLoc l PP.<+> "to" PP.<+> ppLoc t + , ppDoc p + ] + AssumingNoError simErr p -> + PP.vsep [ "Assuming the following error does not occur:" + , PP.indent 2 (ppSimError simErr) + , ppDoc p + ] + +throwUnsupported :: (IsExprBuilder sym, MonadIO m, HasCallStack) => sym -> String -> m a +throwUnsupported sym msg = liftIO $ + do loc <- getCurrentProgramLoc sym + throwIO $ SimError loc $ Unsupported callStack msg + + +-- | Check if an assumption is trivial (always true) +trivialAssumption :: IsExpr e => CrucibleAssumption e -> Bool +trivialAssumption a = asConstantPred (assumptionPred a) == Just True + +ppLocated :: ProgramLoc -> PP.Doc ann -> PP.Doc ann +ppLocated l x = "in" PP.<+> ppFn l PP.<+> ppLoc l PP.<> ":" PP.<+> x + +ppFn :: ProgramLoc -> PP.Doc ann +ppFn l = PP.pretty (plFunction l) + +ppLoc :: ProgramLoc -> PP.Doc ann +ppLoc l = PP.pretty (plSourceLoc l) + +type IsSymInterface sym = + ( IsSymExprBuilder sym + , IsInterpretedFloatSymExprBuilder sym + ) + +data SomeBackend sym = + forall bak. IsSymBackend sym bak => SomeBackend bak + + +-- | Class for backend type that can retrieve sym values. +-- +-- This is separate from `IsSymBackend` specifically to avoid +-- the need for additional class constraints on the `backendGetSym` +-- operation, which is occasionally useful. +class HasSymInterface sym bak | bak -> sym where + -- | Retrive the symbolic expression builder corresponding to this + -- simulator backend. + backendGetSym :: bak -> sym + + +-- | This class provides operations that interact with the symbolic simulator. +-- It allows for logical assumptions/assertions to be added to the current +-- path condition, and allows queries to be asked about branch conditions. +-- +-- The @bak@ type contains all the datastructures necessary to +-- maintain the current program path conditions, and keep track of +-- assumptions and assertions made during program execution. The @sym@ +-- type is expected to satisfy the `IsSymInterface` constraints, which +-- provide access to the What4 expression language. A @sym@ is uniquely +-- determined by a @bak@. +class (IsSymInterface sym, HasSymInterface sym bak) => IsSymBackend sym bak | bak -> sym where + + ---------------------------------------------------------------------- + -- Branch manipulations + + -- | Push a new assumption frame onto the stack. Assumptions and assertions + -- made will now be associated with this frame on the stack until a new + -- frame is pushed onto the stack, or until this one is popped. + pushAssumptionFrame :: bak -> IO AS.FrameIdentifier + + -- | Pop an assumption frame from the stack. The collected assumptions + -- in this frame are returned. Pops are required to be well-bracketed + -- with pushes. In particular, if the given frame identifier is not + -- the identifier of the top frame on the stack, an error will be raised. + popAssumptionFrame :: bak -> AS.FrameIdentifier -> IO (Assumptions sym) + + -- | Pop all assumption frames up to and including the frame with the given + -- frame identifier. This operation will panic if the named frame does + -- not exist on the stack. + popUntilAssumptionFrame :: bak -> AS.FrameIdentifier -> IO () + + -- | Pop an assumption frame from the stack. The collected assummptions + -- in this frame are returned, along with any proof obligations that were + -- incurred while the frame was active. Pops are required to be well-bracketed + -- with pushes. In particular, if the given frame identifier is not + -- the identifier of the top frame on the stack, an error will be raised. + popAssumptionFrameAndObligations :: + bak -> AS.FrameIdentifier -> IO (Assumptions sym, ProofObligations sym) + + ---------------------------------------------------------------------- + -- Assertions + + -- | Add an assumption to the current state. + addAssumption :: bak -> Assumption sym -> IO () + + -- | Add a collection of assumptions to the current state. + addAssumptions :: bak -> Assumptions sym -> IO () + + -- | Get the current path condition as a predicate. This consists of the conjunction + -- of all the assumptions currently in scope. + getPathCondition :: bak -> IO (Pred sym) + + -- | Collect all the assumptions currently in scope + collectAssumptions :: bak -> IO (Assumptions sym) + + -- | Add a new proof obligation to the system. + -- The proof may use the current path condition and assumptions. Note + -- that this *DOES NOT* add the goal as an assumption. See also + -- 'addAssertion'. Also note that predicates that concretely evaluate + -- to True will be silently discarded. See 'addDurableProofObligation' + -- to avoid discarding goals. + addProofObligation :: bak -> Assertion sym -> IO () + addProofObligation bak a = + case asConstantPred (a ^. labeledPred) of + Just True -> return () + _ -> addDurableProofObligation bak a + + -- | Add a new proof obligation to the system which will persist + -- throughout symbolic execution even if it is concretely valid. + -- The proof may use the current path condition and assumptions. Note + -- that this *DOES NOT* add the goal as an assumption. See also + -- 'addDurableAssertion'. + addDurableProofObligation :: bak -> Assertion sym -> IO () + + -- | Get the collection of proof obligations. + getProofObligations :: bak -> IO (ProofObligations sym) + + -- | Forget the current collection of proof obligations. + -- Presumably, we've already used 'getProofObligations' to save them + -- somewhere else. + clearProofObligations :: bak -> IO () + + -- | Create a snapshot of the current assumption state, that may later be restored. + -- This is useful for supporting control-flow patterns that don't neatly fit into + -- the stack push/pop model. + saveAssumptionState :: bak -> IO (AssumptionState sym) + + -- | Restore the assumption state to a previous snapshot. + restoreAssumptionState :: bak -> AssumptionState sym -> IO () + + -- | Reset the assumption state to a fresh, blank state + resetAssumptionState :: bak -> IO () + resetAssumptionState bak = restoreAssumptionState bak PG.emptyGoalCollector + +assertThenAssumeConfigOption :: ConfigOption BaseBoolType +assertThenAssumeConfigOption = configOption knownRepr "assertThenAssume" + +assertThenAssumeOption :: ConfigDesc +assertThenAssumeOption = mkOpt + assertThenAssumeConfigOption + boolOptSty + (Just "Assume a predicate after asserting it.") + (Just (ConcreteBool False)) + +backendOptions :: [ConfigDesc] +backendOptions = [assertThenAssumeOption] + +-- | Add a proof obligation for the given predicate, and then assume it +-- (when the assertThenAssume option is true). +-- Note that assuming the prediate might cause the current execution +-- path to abort, if we happened to assume something that is obviously false. +addAssertion :: + IsSymBackend sym bak => + bak -> Assertion sym -> IO () +addAssertion bak a = + do addProofObligation bak a + assumeAssertion bak a + +-- | Add a durable proof obligation for the given predicate, and then +-- assume it (when the assertThenAssume option is true). +-- Note that assuming the prediate might cause the current execution +-- path to abort, if we happened to assume something that is obviously false. +addDurableAssertion :: IsSymBackend sym bak => bak -> Assertion sym -> IO () +addDurableAssertion bak a = + do addDurableProofObligation bak a + assumeAssertion bak a + +-- | Assume assertion when the assertThenAssume option is true. +assumeAssertion :: IsSymBackend sym bak => bak -> Assertion sym -> IO () +assumeAssertion bak (LabeledPred p msg) = + do let sym = backendGetSym bak + assert_then_assume_opt <- getOpt + =<< getOptionSetting assertThenAssumeConfigOption (getConfiguration sym) + when assert_then_assume_opt $ + addAssumption bak (AssumingNoError msg p) + +-- | Throw an exception, thus aborting the current execution path. +abortExecBecause :: AbortExecReason -> IO a +abortExecBecause err = throwIO err + +-- | Add a proof obligation using the current program location. +-- Afterwards, assume the given fact. +assert :: + IsSymBackend sym bak => + bak -> + Pred sym -> + SimErrorReason -> + IO () +assert bak p msg = + do let sym = backendGetSym bak + loc <- getCurrentProgramLoc sym + addAssertion bak (LabeledPred p (SimError loc msg)) + +-- | Add a proof obligation for False. This always aborts execution +-- of the current path, because after asserting false, we get to assume it, +-- and so there is no need to check anything after. This is why the resulting +-- IO computation can have the fully polymorphic type. +addFailedAssertion :: IsSymBackend sym bak => bak -> SimErrorReason -> IO a +addFailedAssertion bak msg = + do let sym = backendGetSym bak + loc <- getCurrentProgramLoc sym + let err = SimError loc msg + addProofObligation bak (LabeledPred (falsePred sym) err) + abortExecBecause (AssertionFailure err) + +-- | Run the given action to compute a predicate, and assert it. +addAssertionM :: + IsSymBackend sym bak => + bak -> + IO (Pred sym) -> + SimErrorReason -> + IO () +addAssertionM bak pf msg = do + p <- pf + assert bak p msg + +-- | Assert that the given real-valued expression is an integer. +assertIsInteger :: + IsSymBackend sym bak => + bak -> + SymReal sym -> + SimErrorReason -> + IO () +assertIsInteger bak v msg = do + let sym = backendGetSym bak + addAssertionM bak (isInteger sym v) msg + +-- | Given a partial expression, assert that it is defined +-- and return the underlying value. +readPartExpr :: + IsSymBackend sym bak => + bak -> + PartExpr (Pred sym) v -> + SimErrorReason -> + IO v +readPartExpr bak Unassigned msg = do + addFailedAssertion bak msg +readPartExpr bak (PE p v) msg = do + let sym = backendGetSym bak + loc <- getCurrentProgramLoc sym + addAssertion bak (LabeledPred p (SimError loc msg)) + return v + +ppProofObligation :: IsExprBuilder sym => sym -> ProofObligation sym -> IO (PP.Doc ann) +ppProofObligation sym (AS.ProofGoal asmps gl) = + do as <- flattenAssumptions sym asmps + return $ PP.vsep + [ if null as then mempty else + PP.vcat ("Assuming:" : concatMap ppAsm (toList as)) + , "Prove:" + , ppGl + ] + where + ppAsm asm + | not (trivialAssumption asm) = ["* " PP.<> PP.hang 2 (ppAssumption printSymExpr asm)] + | otherwise = [] + + ppGl = + PP.indent 2 $ + PP.vsep [ppSimError (gl^.labeledPredMsg), printSymExpr (gl^.labeledPred)] diff --git a/src/Lang/Crucible/Backend/AssumptionStack.hs b/src/Lang/Crucible/Backend/AssumptionStack.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Backend/AssumptionStack.hs @@ -0,0 +1,256 @@ +{-| +Module : Lang.Crucible.Backend.AssumptionStack +Copyright : (c) Galois, Inc 2018 +License : BSD3 +Maintainer : Rob Dockins + +This module provides management support for keeping track +of a context of logical assumptions. The API provided here +is similar to the interactive mode of an SMT solver. Logical +conditions can be assumed into the current context, and bundles +of assumptions are organized into frames which are pushed and +popped by the user to manage the state. + +Additionally, proof goals can be asserted to the system. These will be +turned into complete logical statements by assuming the current context +and be stashed in a collection of remembered goals for later dispatch to +solvers. +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Lang.Crucible.Backend.AssumptionStack + ( -- * Assertions and proof goals + ProofGoal(..) + , Goals(..) + + -- * Frames and assumption stacks + -- ** Basic data types + , FrameIdentifier + , AssumptionFrame(..) + , AssumptionFrames(..) + , AssumptionStack(..) + -- ** Manipulating assumption stacks + , initAssumptionStack + , saveAssumptionStack + , restoreAssumptionStack + , pushFrame + , popFrame + , popFrameAndGoals + , popFramesUntil + , resetStack + , getProofObligations + , clearProofObligations + , addProofObligation + , inFreshFrame + -- ** Assumption management + , collectAssumptions + , appendAssumptions + , allAssumptionFrames + + ) where + +import Control.Exception (bracketOnError) +import qualified Data.Foldable as F +import Data.IORef +import Data.Parameterized.Nonce + +import Lang.Crucible.Backend.ProofGoals +import Lang.Crucible.Panic (panic) + +-- | A single @AssumptionFrame@ represents a collection +-- of assumptions. They will later be rescinded when +-- the associated frame is popped from the stack. +data AssumptionFrame asmp = + AssumptionFrame + { assumeFrameIdent :: FrameIdentifier + , assumeFrameCond :: asmp + } + +-- | An assumption stack is a data structure for tracking +-- logical assumptions and proof obligations. Assumptions +-- can be added to the current stack frame, and stack frames +-- may be pushed (to remember a previous state) or popped +-- to restore a previous state. +data AssumptionStack asmp ast = + AssumptionStack + { assumeStackGen :: IO FrameIdentifier + , proofObligations :: IORef (GoalCollector asmp ast) + } + + +allAssumptionFrames :: Monoid asmp => AssumptionStack asmp ast -> IO (AssumptionFrames asmp) +allAssumptionFrames stk = + gcFrames <$> readIORef (proofObligations stk) + +-- | Produce a fresh assumption stack. +initAssumptionStack :: NonceGenerator IO t -> IO (AssumptionStack asmp ast) +initAssumptionStack gen = + do let genM = FrameIdentifier . indexValue <$> freshNonce gen + oblsRef <- newIORef emptyGoalCollector + return AssumptionStack + { assumeStackGen = genM + , proofObligations = oblsRef + } + +-- | Record the current state of the assumption stack in a +-- data structure that can later be used to restore the current +-- assumptions. +-- +-- NOTE! however, that proof obligations are NOT copied into the saved +-- stack data. Instead, proof obligations remain only in the original +-- @AssumptionStack@ and the new stack has an empty obligation list. +saveAssumptionStack :: Monoid asmp => AssumptionStack asmp ast -> IO (GoalCollector asmp ast) +saveAssumptionStack stk = + gcRemoveObligations <$> readIORef (proofObligations stk) + +-- | Restore a previously saved assumption stack. Any proof +-- obligations in the saved stack will be copied into the +-- assumption stack, which will also retain any proof obligations +-- it had previously. A saved stack created with `saveAssumptionStack` +-- will have no included proof obligations; restoring such a stack will +-- have no effect on the current proof obligations. +restoreAssumptionStack :: + Monoid asmp => + GoalCollector asmp ast -> + AssumptionStack asmp ast -> + IO () +restoreAssumptionStack gc stk = + modifyIORef' (proofObligations stk) (gcRestore gc) + +-- | Add the given collection logical assumptions to the current stack frame. +appendAssumptions :: + Monoid asmp => asmp -> AssumptionStack asmp ast -> IO () +appendAssumptions ps stk = + modifyIORef' (proofObligations stk) (gcAddAssumes ps) + +-- | Add a new proof obligation to the current collection of obligations based +-- on all the assumptions currently in scope and the predicate in the +-- given assertion. +addProofObligation :: ast -> AssumptionStack asmp ast -> IO () +addProofObligation p stk = modifyIORef' (proofObligations stk) (gcProve p) + + +-- | Collect all the assumptions currently in scope in this stack frame +-- and all previously-pushed stack frames. +collectAssumptions :: Monoid asmp => AssumptionStack asmp ast -> IO asmp +collectAssumptions stk = + do AssumptionFrames base frms <- gcFrames <$> readIORef (proofObligations stk) + return (base <> F.fold (fmap snd frms)) + +-- | Retrieve the current collection of proof obligations. +getProofObligations :: Monoid asmp => AssumptionStack asmp ast -> IO (Maybe (Goals asmp ast)) +getProofObligations stk = gcFinish <$> readIORef (proofObligations stk) + +-- | Remove all pending proof obligations. +clearProofObligations :: Monoid asmp => AssumptionStack asmp ast -> IO () +clearProofObligations stk = + modifyIORef' (proofObligations stk) gcRemoveObligations + +-- | Reset the 'AssumptionStack' to an empty set of assumptions, +-- but retain any pending proof obligations. +resetStack :: Monoid asmp => AssumptionStack asmp ast -> IO () +resetStack stk = modifyIORef' (proofObligations stk) gcReset + +-- | Push a new assumption frame on top of the stack. The +-- returned @FrameIdentifier@ can be used later to pop this +-- frame. Frames must be pushed and popped in a coherent, +-- well-bracketed way. +pushFrame :: AssumptionStack asmp ast -> IO FrameIdentifier +pushFrame stk = + do ident <- assumeStackGen stk + modifyIORef' (proofObligations stk) (gcPush ident) + return ident + +-- | Pop all frames up to and including the frame with the +-- given identifier. The return value indicates how +-- many stack frames were popped. +popFramesUntil :: Monoid asmp => FrameIdentifier -> AssumptionStack asmp ast -> IO Int +popFramesUntil ident stk = atomicModifyIORef' (proofObligations stk) (go 1) + where + go n gc = + case gcPop gc of + Left (ident', _assumes, mg, gc1) + | ident == ident' -> (gc',n) + | otherwise -> go (n+1) gc' + where gc' = case mg of + Nothing -> gc1 + Just g -> gcAddGoals g gc1 + Right _ -> + panic "AssumptionStack.popFrameUntil" + [ "Frame not found in stack." + , "*** Frame to pop: " ++ showFrameId ident + ] + + showFrameId (FrameIdentifier x) = show x + +-- | Pop a previously-pushed assumption frame from the stack. +-- All assumptions in that frame will be forgotten. The +-- assumptions contained in the popped frame are returned. +popFrame :: Monoid asmp => FrameIdentifier -> AssumptionStack asmp ast -> IO asmp +popFrame ident stk = + atomicModifyIORef' (proofObligations stk) $ \gc -> + case gcPop gc of + Left (ident', assumes, mg, gc1) + | ident == ident' -> + let gc' = case mg of + Nothing -> gc1 + Just g -> gcAddGoals g gc1 + in (gc', assumes) + | otherwise -> + panic "AssumptionStack.popFrame" + [ "Push/pop mismatch in assumption stack!" + , "*** Current frame: " ++ showFrameId ident + , "*** Expected ident: " ++ showFrameId ident' + ] + Right _ -> + panic "AssumptionStack.popFrame" + [ "Pop with no push in goal collector." + , "*** Current frame: " ++ showFrameId ident + ] + + where + showFrameId (FrameIdentifier x) = show x + + +popFrameAndGoals :: + Monoid asmp => + FrameIdentifier -> + AssumptionStack asmp ast -> + IO (asmp, Maybe (Goals asmp ast)) +popFrameAndGoals ident stk = + atomicModifyIORef' (proofObligations stk) $ \gc -> + case gcPop gc of + Left (ident', assumes, mg, gc1) + | ident == ident' -> (gc1, (assumes, mg)) + | otherwise -> + panic "AssumptionStack.popFrameAndGoals" + [ "Push/pop mismatch in assumption stack!" + , "*** Current frame: " ++ showFrameId ident + , "*** Expected ident: " ++ showFrameId ident' + ] + Right _ -> + panic "AssumptionStack.popFrameAndGoals" + [ "Pop with no push in goal collector." + , "*** Current frame: " ++ showFrameId ident + ] + + where + showFrameId (FrameIdentifier x) = show x + + +-- | Run an action in the scope of a fresh assumption frame. +-- The frame will be popped and returned on successful +-- completion of the action. If the action raises an exception, +-- the frame will be popped and discarded. +inFreshFrame :: Monoid asmp => AssumptionStack asmp ast -> IO a -> IO (asmp, a) +inFreshFrame stk action = + bracketOnError + (pushFrame stk) + (\ident -> popFrame ident stk) + (\ident -> do x <- action + frm <- popFrame ident stk + return (frm, x)) diff --git a/src/Lang/Crucible/Backend/Online.hs b/src/Lang/Crucible/Backend/Online.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Backend/Online.hs @@ -0,0 +1,610 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Backend.Online +-- Description : A solver backend that maintains a persistent connection +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- The online backend maintains an open connection to an SMT solver +-- that is used to prune unsatisfiable execution traces during simulation. +-- At every symbolic branch point, the SMT solver is queried to determine +-- if one or both symbolic branches are unsatisfiable. +-- Only branches with satisfiable branch conditions are explored. +-- +-- The online backend also allows override definitions access to a +-- persistent SMT solver connection. This can be useful for some +-- kinds of algorithms that benefit from quickly performing many +-- small solver queries in a tight interaction loop. +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Lang.Crucible.Backend.Online + ( -- * OnlineBackend + OnlineBackend + , withOnlineBackend + , newOnlineBackend + , checkSatisfiable + , checkSatisfiableWithModel + , withSolverProcess + , resetSolverProcess + , restoreSolverState + , UnsatFeatures(..) + , unsatFeaturesToProblemFeatures + -- ** Configuration options + , solverInteractionFile + , enableOnlineBackend + , onlineBackendOptions + -- ** Branch satisfiability + , BranchResult(..) + , considerSatisfiability + -- ** Yices + , YicesOnlineBackend + , withYicesOnlineBackend + -- ** Z3 + , Z3OnlineBackend + , withZ3OnlineBackend + -- ** Boolector + , BoolectorOnlineBackend + , withBoolectorOnlineBackend + -- ** CVC4 + , CVC4OnlineBackend + , withCVC4OnlineBackend + -- ** CVC5 + , CVC5OnlineBackend + , withCVC5OnlineBackend + -- ** STP + , STPOnlineBackend + , withSTPOnlineBackend + ) where + + +import Control.Lens ( (^.) ) +import Control.Monad +import Control.Monad.Fix (mfix) +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Bits +import Data.Data (Data) +import Data.Foldable +import Data.IORef +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.IO +import qualified Data.Text as Text +import qualified Prettyprinter as PP + +import What4.Config +import What4.Concrete +import qualified What4.Expr.Builder as B +import What4.Interface +import What4.ProblemFeatures +import What4.ProgramLoc +import What4.Protocol.Online +import What4.Protocol.SMTWriter as SMT +import What4.Protocol.SMTLib2 as SMT2 +import What4.SatResult +import qualified What4.Solver.Boolector as Boolector +import qualified What4.Solver.CVC4 as CVC4 +import qualified What4.Solver.CVC5 as CVC5 +import qualified What4.Solver.STP as STP +import qualified What4.Solver.Yices as Yices +import qualified What4.Solver.Z3 as Z3 + +import Lang.Crucible.Backend +import Lang.Crucible.Backend.AssumptionStack as AS +import qualified Lang.Crucible.Backend.ProofGoals as PG +import Lang.Crucible.Simulator.SimError + +data UnsatFeatures + = NoUnsatFeatures + -- ^ Do not compute unsat cores or assumptions + | ProduceUnsatCores + -- ^ Enable named assumptions and unsat-core computations + | ProduceUnsatAssumptions + -- ^ Enable check-with-assumptions commands and unsat-assumptions computations + +unsatFeaturesToProblemFeatures :: UnsatFeatures -> ProblemFeatures +unsatFeaturesToProblemFeatures x = + case x of + NoUnsatFeatures -> noFeatures + ProduceUnsatCores -> useUnsatCores + ProduceUnsatAssumptions -> useUnsatAssumptions + +solverInteractionFile :: ConfigOption (BaseStringType Unicode) +solverInteractionFile = configOption knownRepr "solverInteractionFile" + +-- | Option for enabling online solver interactions. Defaults to true. +-- If disabled, operations requiring solver connections will be skipped. +enableOnlineBackend :: ConfigOption BaseBoolType +enableOnlineBackend = configOption knownRepr "enableOnlineBackend" + +onlineBackendOptions :: OnlineSolver solver => OnlineBackend solver scope st fs -> [ConfigDesc] +onlineBackendOptions bak = + [ mkOpt + solverInteractionFile + stringOptSty + (Just (PP.pretty "File to echo solver commands and responses for debugging purposes")) + Nothing + , let enableOnset _ (ConcreteBool val) = + do when (not val) (resetSolverProcess bak) + return optOK + in mkOpt + enableOnlineBackend + boolOptSty{ opt_onset = enableOnset } + (Just (PP.pretty "Enable online solver communications")) + (Just (ConcreteBool True)) + ] + +-------------------------------------------------------------------------------- +-- OnlineBackend + +-- | Is the solver running or not? +data SolverState scope solver = + SolverNotStarted + | SolverStarted (SolverProcess scope solver) (Maybe Handle) + +-- | This represents the state of the backend along a given execution. +-- It contains the current assertions and program location. +data OnlineBackend solver scope st fs = OnlineBackendState + { assumptionStack :: + !(AssumptionStack + (CrucibleAssumptions (B.Expr scope)) + (LabeledPred (B.BoolExpr scope) SimError)) + + , solverProc :: !(IORef (SolverState scope solver)) + -- ^ The solver process, if any. + + , currentFeatures :: !(IORef ProblemFeatures) + + , onlineEnabled :: IO Bool + -- ^ action for checking if online features are currently enabled + + , onlineExprBuilder :: B.ExprBuilder scope st fs + } + +newOnlineBackend :: + OnlineSolver solver => + B.ExprBuilder scope st fs -> + ProblemFeatures -> + IO (OnlineBackend solver scope st fs) +newOnlineBackend sym feats = + do stk <- initAssumptionStack (sym ^. B.exprCounter) + procref <- newIORef SolverNotStarted + featref <- newIORef feats + + mfix $ \bak -> + do tryExtendConfig + (backendOptions ++ onlineBackendOptions bak) + (getConfiguration sym) + + enableOpt <- getOptionSetting enableOnlineBackend (getConfiguration sym) + + return $ OnlineBackendState + { assumptionStack = stk + , solverProc = procref + , currentFeatures = featref + , onlineEnabled = getOpt enableOpt + , onlineExprBuilder = sym + } + +-- | Do something with an online backend. +-- The backend is only valid in the continuation. +-- +-- Solver specific configuration options are not automatically installed +-- by this operation. +withOnlineBackend :: + (OnlineSolver solver, MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + ProblemFeatures -> + (OnlineBackend solver scope st fs -> m a) -> + m a +withOnlineBackend sym feats action = do + bak <- liftIO (newOnlineBackend sym feats) + action bak + `finally` + (liftIO $ readIORef (solverProc bak) >>= \case + SolverNotStarted {} -> return () + SolverStarted p auxh -> + ((void $ shutdownSolverProcess p) `onException` (killSolver p)) + `finally` + (maybe (return ()) hClose auxh) + ) + + +type YicesOnlineBackend scope st fs = OnlineBackend Yices.Connection scope st fs + +-- | Do something with a Yices online backend. +-- The backend is only valid in the continuation. +-- +-- The Yices configuration options will be automatically +-- installed into the backend configuration object. +-- +-- n.b. the explicit forall allows the fs to be expressed as the +-- first argument so that it can be dictated easily from the caller. +-- Example: +-- +-- > withYicesOnlineBackend FloatRealRepr ng f' +withYicesOnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + UnsatFeatures -> + ProblemFeatures -> + (YicesOnlineBackend scope st fs -> m a) -> + m a +withYicesOnlineBackend sym unsatFeat extraFeatures action = + let feat = Yices.yicesDefaultFeatures .|. unsatFeaturesToProblemFeatures unsatFeat .|. extraFeatures in + withOnlineBackend sym feat $ \bak -> + do liftIO $ tryExtendConfig Yices.yicesOptions (getConfiguration sym) + action bak + +type Z3OnlineBackend scope st fs = OnlineBackend (SMT2.Writer Z3.Z3) scope st fs + +-- | Do something with a Z3 online backend. +-- The backend is only valid in the continuation. +-- +-- The Z3 configuration options will be automatically +-- installed into the backend configuration object. +-- +-- n.b. the explicit forall allows the fs to be expressed as the +-- first argument so that it can be dictated easily from the caller. +-- Example: +-- +-- > withz3OnlineBackend FloatRealRepr ng f' +withZ3OnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + UnsatFeatures -> + ProblemFeatures -> + (Z3OnlineBackend scope st fs -> m a) -> + m a +withZ3OnlineBackend sym unsatFeat extraFeatures action = + let feat = (SMT2.defaultFeatures Z3.Z3 .|. unsatFeaturesToProblemFeatures unsatFeat .|. extraFeatures) in + withOnlineBackend sym feat $ \bak -> + do liftIO $ tryExtendConfig Z3.z3Options (getConfiguration sym) + action bak + +type BoolectorOnlineBackend scope st fs = OnlineBackend (SMT2.Writer Boolector.Boolector) scope st fs + +-- | Do something with a Boolector online backend. +-- The backend is only valid in the continuation. +-- +-- The Boolector configuration options will be automatically +-- installed into the backend configuration object. +-- +-- > withBoolectorOnineBackend FloatRealRepr ng f' +withBoolectorOnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + UnsatFeatures -> + (BoolectorOnlineBackend scope st fs -> m a) -> + m a +withBoolectorOnlineBackend sym unsatFeat action = + let feat = (SMT2.defaultFeatures Boolector.Boolector .|. unsatFeaturesToProblemFeatures unsatFeat) in + withOnlineBackend sym feat $ \bak -> do + liftIO $ tryExtendConfig Boolector.boolectorOptions (getConfiguration sym) + action bak + +type CVC4OnlineBackend scope st fs = OnlineBackend (SMT2.Writer CVC4.CVC4) scope st fs + +-- | Do something with a CVC4 online backend. +-- The backend is only valid in the continuation. +-- +-- The CVC4 configuration options will be automatically +-- installed into the backend configuration object. +-- +-- n.b. the explicit forall allows the fs to be expressed as the +-- first argument so that it can be dictated easily from the caller. +-- Example: +-- +-- > withCVC4OnlineBackend FloatRealRepr ng f' +withCVC4OnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + UnsatFeatures -> + ProblemFeatures -> + (CVC4OnlineBackend scope st fs -> m a) -> + m a +withCVC4OnlineBackend sym unsatFeat extraFeatures action = + let feat = (SMT2.defaultFeatures CVC4.CVC4 .|. unsatFeaturesToProblemFeatures unsatFeat .|. extraFeatures) in + withOnlineBackend sym feat $ \bak -> do + liftIO $ tryExtendConfig CVC4.cvc4Options (getConfiguration sym) + action bak + +type CVC5OnlineBackend scope st fs = OnlineBackend (SMT2.Writer CVC5.CVC5) scope st fs + +-- | Do something with a CVC5 online backend. +-- The backend is only valid in the continuation. +-- +-- The CVC5 configuration options will be automatically +-- installed into the backend configuration object. +-- +-- n.b. the explicit forall allows the fs to be expressed as the +-- first argument so that it can be dictated easily from the caller. +-- Example: +-- +-- > withCVC5OnlineBackend FloatRealRepr ng f' +withCVC5OnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + UnsatFeatures -> + ProblemFeatures -> + (CVC5OnlineBackend scope st fs -> m a) -> + m a +withCVC5OnlineBackend sym unsatFeat extraFeatures action = + let feat = (SMT2.defaultFeatures CVC5.CVC5 .|. unsatFeaturesToProblemFeatures unsatFeat .|. extraFeatures) in + withOnlineBackend sym feat $ \bak -> do + liftIO $ tryExtendConfig CVC5.cvc5Options (getConfiguration sym) + action bak + +type STPOnlineBackend scope st fs = OnlineBackend (SMT2.Writer STP.STP) scope st fs + +-- | Do something with a STP online backend. +-- The backend is only valid in the continuation. +-- +-- The STO configuration options will be automatically +-- installed into the backend configuration object. +-- +-- n.b. the explicit forall allows the fs to be expressed as the +-- first argument so that it can be dictated easily from the caller. +-- Example: +-- +-- > withSTPOnlineBackend FloatRealRepr ng f' +withSTPOnlineBackend :: + (MonadIO m, MonadMask m) => + B.ExprBuilder scope st fs -> + (STPOnlineBackend scope st fs -> m a) -> + m a +withSTPOnlineBackend sym action = + withOnlineBackend sym (SMT2.defaultFeatures STP.STP) $ \bak -> do + liftIO $ tryExtendConfig STP.stpOptions (getConfiguration sym) + action bak + +-- | Shutdown any currently-active solver process. +-- A fresh solver process will be started on the +-- next call to `getSolverProcess`. +resetSolverProcess :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + IO () +resetSolverProcess bak = do + do mproc <- readIORef (solverProc bak) + case mproc of + -- Nothing to do + SolverNotStarted -> return () + SolverStarted p auxh -> + do _ <- shutdownSolverProcess p + maybe (return ()) hClose auxh + writeIORef (solverProc bak) SolverNotStarted + + +restoreSolverState :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + PG.GoalCollector (CrucibleAssumptions (B.Expr scope)) + (LabeledPred (B.BoolExpr scope) SimError) -> + IO () +restoreSolverState bak gc = + do mproc <- readIORef (solverProc bak) + case mproc of + -- Nothing to do, state will be restored next time we start the process + SolverNotStarted -> return () + + SolverStarted proc auxh -> + (do -- reset the solver state + reset proc + -- restore the assumption structure + restoreAssumptionFrames bak proc (PG.gcFrames gc)) + `onException` + ((killSolver proc) + `finally` + (maybe (return ()) hClose auxh) + `finally` + (writeIORef (solverProc bak) SolverNotStarted)) + + +-- | Get the solver process. Starts the solver, if that hasn't +-- happened already and apply the given action. +-- If the @enableOnlineBackend@ option is False, the action +-- is skipped instead, and the solver is not started. +withSolverProcess :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + IO a {- ^ Default value to return if online features are disabled -} -> + (SolverProcess scope solver -> IO a) -> + IO a +withSolverProcess bak def action = do + let sym = onlineExprBuilder bak + onlineEnabled bak >>= \case + False -> def + True -> + do let stk = assumptionStack bak + mproc <- readIORef (solverProc bak) + auxOutSetting <- getOptionSetting solverInteractionFile (getConfiguration sym) + (p, auxh) <- + case mproc of + SolverStarted p auxh -> return (p, auxh) + SolverNotStarted -> + do feats <- readIORef (currentFeatures bak) + auxh <- + getMaybeOpt auxOutSetting >>= \case + Nothing -> return Nothing + Just fn + | Text.null fn -> return Nothing + | otherwise -> Just <$> openFile (Text.unpack fn) WriteMode + p <- startSolverProcess feats auxh sym + -- set up the solver in the same assumption state as specified + -- by the current assumption stack + (do frms <- AS.allAssumptionFrames stk + restoreAssumptionFrames bak p frms + ) `onException` + (killSolver p `finally` maybe (return ()) hClose auxh) + writeIORef (solverProc bak) (SolverStarted p auxh) + return (p, auxh) + + case solverErrorBehavior p of + ContinueOnError -> + action p + ImmediateExit -> + onException + (action p) + ((killSolver p) + `finally` + (maybe (return ()) hClose auxh) + `finally` + (writeIORef (solverProc bak) SolverNotStarted)) + +-- | Get the connection for sending commands to the solver. +withSolverConn :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + (WriterConn scope solver -> IO ()) -> + IO () +withSolverConn bak k = withSolverProcess bak (pure ()) (k . solverConn) + + +-- | Result of attempting to branch on a predicate. +data BranchResult + -- | The both branches of the predicate might be satisfiable + -- (although satisfiablility of either branch is not guaranteed). + = IndeterminateBranchResult + + -- | Commit to the branch where the given predicate is equal to + -- the returned boolean. The opposite branch is unsatisfiable + -- (although the given branch is not necessarily satisfiable). + | NoBranch !Bool + + -- | The context before considering the given predicate was already + -- unsatisfiable. + | UnsatisfiableContext + deriving (Data, Eq, Generic, Ord, Typeable) + + +restoreAssumptionFrames :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + SolverProcess scope solver -> + AssumptionFrames (CrucibleAssumptions (B.Expr scope)) -> + IO () +restoreAssumptionFrames bak proc (AssumptionFrames base frms) = + do let sym = onlineExprBuilder bak + -- assume the base-level assumptions + SMT.assume (solverConn proc) =<< assumptionsPred sym base + + -- populate the pushed frames + forM_ (map snd $ toList frms) $ \frm -> + do push proc + SMT.assume (solverConn proc) =<< assumptionsPred sym frm + +considerSatisfiability :: + OnlineSolver solver => + OnlineBackend solver scope st fs -> + Maybe ProgramLoc -> + B.BoolExpr scope -> + IO BranchResult +considerSatisfiability bak mbPloc p = + let sym = onlineExprBuilder bak in + withSolverProcess bak (pure IndeterminateBranchResult) $ \proc -> + do pnot <- notPred sym p + let locDesc = case mbPloc of + Just ploc -> show (plSourceLoc ploc) + Nothing -> "(unknown location)" + let rsn = "branch sat: " ++ locDesc + p_res <- checkSatisfiable proc rsn p + pnot_res <- checkSatisfiable proc rsn pnot + case (p_res, pnot_res) of + (Unsat{}, Unsat{}) -> return UnsatisfiableContext + (_ , Unsat{}) -> return (NoBranch True) + (Unsat{}, _ ) -> return (NoBranch False) + _ -> return IndeterminateBranchResult + + +instance HasSymInterface (B.ExprBuilder t st fs) (OnlineBackend solver t st fs) where + backendGetSym = onlineExprBuilder + +instance (IsSymInterface (B.ExprBuilder scope st fs), OnlineSolver solver) => + IsSymBackend (B.ExprBuilder scope st fs) + (OnlineBackend solver scope st fs) where + + addDurableProofObligation bak a = + AS.addProofObligation a (assumptionStack bak) + + addAssumption bak a = + case impossibleAssumption a of + Just rsn -> abortExecBecause rsn + Nothing -> + do -- Send assertion to the solver, unless it is trivial. + let p = assumptionPred a + unless (asConstantPred p == Just True) $ + withSolverConn bak $ \conn -> SMT.assume conn p + + -- Record assumption, even if trivial. + -- This allows us to keep track of the full path we are on. + AS.appendAssumptions (singleAssumption a) (assumptionStack bak) + + addAssumptions bak as = + -- NB, don't add the assumption to the assumption stack unless + -- the solver assumptions succeeded + do let sym = backendGetSym bak + p <- assumptionsPred sym as + + -- Tell the solver of assertions + unless (asConstantPred p == Just True) $ + withSolverConn bak $ \conn -> SMT.assume conn p + + -- Add assertions to list + appendAssumptions as (assumptionStack bak) + + getPathCondition bak = + do let sym = backendGetSym bak + ps <- AS.collectAssumptions (assumptionStack bak) + assumptionsPred sym ps + + collectAssumptions bak = + AS.collectAssumptions (assumptionStack bak) + + pushAssumptionFrame bak = + -- NB, don't push a frame in the assumption stack unless + -- pushing to the solver succeeded + do withSolverProcess bak (pure ()) push + pushFrame (assumptionStack bak) + + popAssumptionFrame bak ident = + -- NB, pop the frame whether or not the solver pop succeeds + do frm <- popFrame ident (assumptionStack bak) + withSolverProcess bak (pure ()) pop + return frm + + popUntilAssumptionFrame bak ident = + -- NB, pop the frames whether or not the solver pop succeeds + do n <- AS.popFramesUntil ident (assumptionStack bak) + withSolverProcess bak (pure ()) $ \proc -> + forM_ [0..(n-1)] $ \_ -> pop proc + + popAssumptionFrameAndObligations bak ident = do + -- NB, pop the frames whether or not the solver pop succeeds + do frmAndGls <- popFrameAndGoals ident (assumptionStack bak) + withSolverProcess bak (pure ()) pop + return frmAndGls + + getProofObligations bak = + AS.getProofObligations (assumptionStack bak) + + clearProofObligations bak = + AS.clearProofObligations (assumptionStack bak) + + saveAssumptionState bak = + AS.saveAssumptionStack (assumptionStack bak) + + restoreAssumptionState bak gc = + do restoreSolverState bak gc + -- restore the previous assumption stack + AS.restoreAssumptionStack gc (assumptionStack bak) diff --git a/src/Lang/Crucible/Backend/ProofGoals.hs b/src/Lang/Crucible/Backend/ProofGoals.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Backend/ProofGoals.hs @@ -0,0 +1,358 @@ +{-| +Module : Lang.Crucible.Backend.ProofGoals +Copyright : (c) Galois, Inc 2014-2018 +License : BSD3 + +This module defines a data strucutre for storing a collection of +proof obligations, and the current state of assumptions. +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Lang.Crucible.Backend.ProofGoals + ( -- * Goals + ProofGoal(..), Goals(..), goalsToList, proveAll, goalsConj + -- ** traversals + , traverseGoals, traverseOnlyGoals + , traverseGoalsWithAssumptions + , traverseGoalsSeq + + -- * Goal collector + , FrameIdentifier(..), GoalCollector + , emptyGoalCollector + + -- ** traversals + , traverseGoalCollector + , traverseGoalCollectorWithAssumptions + + -- ** Context management + , gcAddAssumes, gcProve + , gcPush, gcPop, gcAddGoals, + + -- ** Global operations on context + gcRemoveObligations, gcRestore, gcReset, gcFinish + + -- ** Viewing the assumption state + , AssumptionFrames(..), gcFrames + ) + where + +import Control.Monad.Reader +import Data.Functor.Const +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Word + +-- | A proof goal consists of a collection of assumptions +-- that were in scope when an assertion was made, together +-- with the given assertion. +data ProofGoal asmp goal = + ProofGoal + { proofAssumptions :: asmp + , proofGoal :: goal + } + +-- | A collection of goals, which can represent shared assumptions. +data Goals asmp goal = + -- | Make an assumption that is in context for all the + -- contained goals. + Assuming asmp !(Goals asmp goal) + + -- | A proof obligation, to be proved in the context of + -- all previously-made assumptions. + | Prove goal + + -- | A conjunction of two goals. + | ProveConj !(Goals asmp goal) !(Goals asmp goal) + deriving Show + +-- | Construct a goal that first assumes a collection of +-- assumptions and then states a goal. +assuming :: Monoid asmp => asmp -> Goals asmp goal -> Goals asmp goal +assuming as (Assuming bs g) = assuming (as <> bs) g +assuming as g = Assuming as g + +-- | Construct a 'Goals' object from a collection of subgoals, all of +-- which are to be proved. This yields 'Nothing' if the collection +-- of goals is empty, and otherwise builds a conjunction of all the +-- goals. Note that there is no new sharing in the resulting structure. +proveAll :: Foldable t => t (Goals asmp goal) -> Maybe (Goals asmp goal) +proveAll = foldr f Nothing + where + f x Nothing = Just $! x + f x (Just y) = Just $! ProveConj x y + +-- | Helper to conjoin two possibly trivial 'Goals' objects. +goalsConj :: Maybe (Goals asmp goal) -> Maybe (Goals asmp goal) -> Maybe (Goals asmp goal) +goalsConj Nothing y = y +goalsConj x Nothing = x +goalsConj (Just x) (Just y) = Just (ProveConj x y) + +-- | Render the tree of goals as a list instead, duplicating +-- shared assumptions over each goal as necessary. +goalsToList :: Monoid asmp => Goals asmp goal -> [ProofGoal asmp goal] +goalsToList = + getConst . traverseGoalsWithAssumptions + (\as g -> Const [ProofGoal as g]) + +-- | Traverse the structure of a 'Goals' data structure. The function for +-- visiting goals my decide to remove the goal from the structure. If +-- no goals remain after the traversal, the resulting value will be a 'Nothing'. +-- +-- In a call to 'traverseGoals assumeAction transformer goals', the +-- arguments are used as follows: +-- +-- * 'traverseGoals' is an action is called every time we encounter +-- an 'Assuming' constructor. The first argument is the original +-- sequence of assumptions. The second argument is a continuation +-- action. The result is a sequence of transformed assumptions +-- and the result of the continuation action. +-- +-- * 'assumeAction' is a transformer action on goals. Return +-- 'Nothing' if you wish to remove the goal from the overall tree. +traverseGoals :: (Applicative f, Monoid asmp') => + (forall a. asmp -> f a -> f (asmp', a)) + -> (goal -> f (Maybe goal')) + -> Goals asmp goal + -> f (Maybe (Goals asmp' goal')) +traverseGoals fas fgl = go + where + go (Prove gl) = fmap Prove <$> fgl gl + go (Assuming as gl) = assuming' <$> fas as (go gl) + go (ProveConj g1 g2) = goalsConj <$> go g1 <*> go g2 + + assuming' (_, Nothing) = Nothing + assuming' (as, Just g) = Just $! assuming as g + + +traverseOnlyGoals :: (Applicative f, Monoid asmp) => + (goal -> f (Maybe goal')) -> + Goals asmp goal -> f (Maybe (Goals asmp goal')) +traverseOnlyGoals f = traverseGoals (\as m -> (as,) <$> m) f + +-- | Traverse a sequence of 'Goals' data structures. See 'traverseGoals' +-- for an explanation of the action arguments. The resulting sequence +-- may be shorter than the original if some 'Goals' become trivial. +traverseGoalsSeq :: (Applicative f, Monoid asmp') => + (forall a. asmp -> f a -> f (asmp', a)) -> + (goal -> f (Maybe goal')) -> + Seq (Goals asmp goal) -> f (Seq (Goals asmp' goal')) +traverseGoalsSeq fas fgl = go + where + go Seq.Empty = pure Seq.Empty + go (g Seq.:<| gs) = combine <$> traverseGoals fas fgl g <*> go gs + + combine Nothing gs = gs + combine (Just g) gs = g Seq.<| gs + +-- | Visit every goal in a 'Goals' structure, remembering the sequence of +-- assumptions along the way to that goal. +traverseGoalsWithAssumptions :: (Applicative f, Monoid asmp) => + (asmp -> goal -> f (Maybe goal')) -> + Goals asmp goal -> f (Maybe (Goals asmp goal')) + +traverseGoalsWithAssumptions f gls = + runReaderT (traverseGoals fas fgl gls) mempty + where + fas a m = (a,) <$> withReaderT (<> a) m + fgl gl = ReaderT $ \as -> f as gl + + +-- | A @FrameIdentifier@ is a value that identifies an +-- an assumption frame. These are expected to be unique +-- when a new frame is pushed onto the stack. This is +-- primarily a debugging aid, to ensure that stack management +-- remains well-bracketed. +newtype FrameIdentifier = FrameIdentifier Word64 + deriving(Eq,Ord) + + +-- | A data-strucutre that can incrementally collect goals in context. +-- It keeps track both of the collection of assumptions that lead to +-- the current state, as well as any proof obligations incurred along +-- the way. +data GoalCollector asmp goal + = TopCollector !(Seq (Goals asmp goal)) + | CollectorFrame !FrameIdentifier !(GoalCollector asmp goal) + | CollectingAssumptions !asmp !(GoalCollector asmp goal) + | CollectingGoals !(Seq (Goals asmp goal)) !(GoalCollector asmp goal) + +-- | A collector with no goals and no context. +emptyGoalCollector :: GoalCollector asmp goal +emptyGoalCollector = TopCollector mempty + +-- | Traverse the goals in a 'GoalCollector. See 'traverseGoals' +-- for an explaination of the action arguments. +traverseGoalCollector :: (Applicative f, Monoid asmp') => + (forall a. asmp -> f a -> f (asmp', a)) -> + (goal -> f (Maybe goal')) -> + GoalCollector asmp goal -> f (GoalCollector asmp' goal') +traverseGoalCollector fas fgl = go + where + go (TopCollector gls) = TopCollector <$> traverseGoalsSeq fas fgl gls + go (CollectorFrame fid gls) = CollectorFrame fid <$> go gls + go (CollectingAssumptions asmps gls) = CollectingAssumptions <$> (fst <$> fas asmps (pure ())) <*> go gls + go (CollectingGoals gs gls) = CollectingGoals <$> traverseGoalsSeq fas fgl gs <*> go gls + +-- | Traverse the goals in a 'GoalCollector', keeping track, +-- for each goal, of the assumptions leading to that goal. +traverseGoalCollectorWithAssumptions :: (Applicative f, Monoid asmp) => + (asmp -> goal -> f (Maybe goal')) -> + GoalCollector asmp goal -> f (GoalCollector asmp goal') +traverseGoalCollectorWithAssumptions f gc = + runReaderT (traverseGoalCollector fas fgl gc) mempty + where + fas a m = (a,) <$> withReaderT (<> a) m + fgl gl = ReaderT $ \as -> f as gl + + +-- | The 'AssumptionFrames' data structure captures the current state of +-- assumptions made inside a 'GoalCollector'. +data AssumptionFrames asmp = + AssumptionFrames + { -- | Assumptions made at the top level of a solver. + baseFrame :: !asmp + -- | A sequence of pushed frames, together with the assumptions that + -- were made in each frame. The sequence is organized with newest + -- frames on the end (right side) of the sequence. + , pushedFrames :: !(Seq (FrameIdentifier, asmp)) + } + +-- | Return a list of all the assumption frames in this goal collector. +-- The first element of the pair is a collection of assumptions made +-- unconditionaly at top level. The remaining list is a sequence of +-- assumption frames, each consisting of a collection of assumptions +-- made in that frame. Frames closer to the front of the list +-- are older. A `gcPop` will remove the newest (rightmost) frame from the list. +gcFrames :: forall asmp goal. Monoid asmp => GoalCollector asmp goal -> AssumptionFrames asmp +gcFrames = go mempty mempty + where + go :: + asmp -> + Seq (FrameIdentifier, asmp) -> + GoalCollector asmp goal -> + AssumptionFrames asmp + + go as fs (TopCollector _) + = AssumptionFrames as fs + + go as fs (CollectorFrame frmid gc) = + go mempty ((frmid, as) Seq.<| fs) gc + + go as fs (CollectingAssumptions as' gc) = + go (as' <> as) fs gc + + go as fs (CollectingGoals _ gc) = + go as fs gc + +-- | Mark the current frame. Using 'gcPop' will unwind to here. +gcPush :: FrameIdentifier -> GoalCollector asmp goal -> GoalCollector asmp goal +gcPush frmid gc = CollectorFrame frmid gc + +gcAddGoals :: Goals asmp goal -> GoalCollector asmp goal -> GoalCollector asmp goal +gcAddGoals g (TopCollector gs) = TopCollector (gs Seq.|> g) +gcAddGoals g (CollectingGoals gs gc) = CollectingGoals (gs Seq.|> g) gc +gcAddGoals g gc = CollectingGoals (Seq.singleton g) gc + +-- | Add a new proof obligation to the current context. +gcProve :: goal -> GoalCollector asmp goal -> GoalCollector asmp goal +gcProve g = gcAddGoals (Prove g) + +-- | Add a sequence of extra assumptions to the current context. +gcAddAssumes :: Monoid asmp => asmp -> GoalCollector asmp goal -> GoalCollector asmp goal +gcAddAssumes as' (CollectingAssumptions as gls) = CollectingAssumptions (as <> as') gls +gcAddAssumes as' gls = CollectingAssumptions as' gls + +{- | Pop to the last push, or all the way to the top, if there were no more pushes. +If the result is 'Left', then we popped until an explicitly marked push; +in that case we return: + + 1. the frame identifier of the popped frame, + 2. the assumptions that were forgotten, + 3. any proof goals that were generated since the frame push, and + 4. the state of the collector before the push. + +If the result is 'Right', then we popped all the way to the top, and the +result is the goal tree, or 'Nothing' if there were no goals. -} + +gcPop :: + Monoid asmp => + GoalCollector asmp goal -> + Either (FrameIdentifier, asmp, Maybe (Goals asmp goal), GoalCollector asmp goal) + (Maybe (Goals asmp goal)) +gcPop = go Nothing mempty + where + + {- The function `go` completes frames one at a time. The "hole" is what + we should use to complete the current path. If it is 'Nothing', then + there was nothing interesting on the current path, and we discard + assumptions that lead to here -} + go hole _as (TopCollector gs) = + Right (goalsConj (proveAll gs) hole) + + go hole as (CollectorFrame fid gc) = + Left (fid, as, hole, gc) + + go hole as (CollectingAssumptions as' gc) = + go (assuming as' <$> hole) (as' <> as) gc + + go hole as (CollectingGoals gs gc) = + go (goalsConj (proveAll gs) hole) as gc + +-- | Get all currently collected goals. +gcFinish :: Monoid asmp => GoalCollector asmp goal -> Maybe (Goals asmp goal) +gcFinish gc = case gcPop gc of + Left (_,_,Just g,gc1) -> gcFinish (gcAddGoals g gc1) + Left (_,_,Nothing,gc1) -> gcFinish gc1 + Right a -> a + +-- | Reset the goal collector to the empty assumption state; but first +-- collect all the pending proof goals and stash them. +gcReset :: Monoid asmp => GoalCollector asmp goal -> GoalCollector asmp goal +gcReset gc = TopCollector gls + where + gls = case gcFinish gc of + Nothing -> mempty + Just p -> Seq.singleton p + +pushGoalsToTop :: Goals asmp goal -> GoalCollector asmp goal -> GoalCollector asmp goal +pushGoalsToTop gls = go + where + go (TopCollector gls') = TopCollector (gls' Seq.|> gls) + go (CollectorFrame fid gc) = CollectorFrame fid (go gc) + go (CollectingAssumptions as gc) = CollectingAssumptions as (go gc) + go (CollectingGoals gs gc) = CollectingGoals gs (go gc) + +-- | This operation restores the assumption state of the first given +-- `GoalCollector`, overwriting the assumptions state of the second +-- collector. However, all proof obligations in the second collector +-- are retained and placed into the the first goal collector in the +-- base assumption level. +-- +-- The end result is a goal collector that maintains all the active +-- proof obligations of both collectors, and has the same +-- assumption context as the first collector. +gcRestore :: + Monoid asmp => + GoalCollector asmp goal {- ^ The assumption state to restore -} -> + GoalCollector asmp goal {- ^ The assumptions state to overwrite -} -> + GoalCollector asmp goal +gcRestore restore old = + case gcFinish old of + Nothing -> restore + Just p -> pushGoalsToTop p restore + +-- | Remove all collected proof obligations, but keep the current set +-- of assumptions. +gcRemoveObligations :: Monoid asmp => GoalCollector asmp goal -> GoalCollector asmp goal +gcRemoveObligations = go + where + go (TopCollector _) = TopCollector mempty + go (CollectorFrame fid gc) = CollectorFrame fid (go gc) + go (CollectingAssumptions as gc) = + case go gc of + CollectingAssumptions as' gc' -> CollectingAssumptions (as <> as') gc' + gc' -> CollectingAssumptions as gc' + go (CollectingGoals _ gc) = go gc diff --git a/src/Lang/Crucible/Backend/Simple.hs b/src/Lang/Crucible/Backend/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Backend/Simple.hs @@ -0,0 +1,118 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Backend.Simple +-- Description : The "simple" solver backend +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- An "offline" backend for communicating with solvers. This backend +-- does not maintain a persistent connection to a solver, and does +-- not perform satisfiability checks at symbolic branch points. +------------------------------------------------------------------------ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Lang.Crucible.Backend.Simple + ( -- * SimpleBackend + SimpleBackend + , newSimpleBackend + -- * Re-exports + , B.FloatMode + , B.FloatModeRepr(..) + , B.FloatIEEE + , B.FloatUninterpreted + , B.FloatReal + , B.Flags + ) where + +import Control.Lens ( (^.) ) +import Control.Monad (void) + +import What4.Config +import What4.Interface +import qualified What4.Expr.Builder as B + +import qualified Lang.Crucible.Backend.AssumptionStack as AS +import Lang.Crucible.Backend +import Lang.Crucible.Simulator.SimError + +------------------------------------------------------------------------ +-- SimpleBackendState + +-- | This represents the state of the backend along a given execution. +-- It contains the current assertion stack. + +type AS t = + AssumptionStack (CrucibleAssumptions (B.Expr t)) + (LabeledPred (B.BoolExpr t) SimError) + +data SimpleBackend t st fs = + SimpleBackend + { sbAssumptionStack :: AS t + , sbExprBuilder :: B.ExprBuilder t st fs + } + +newSimpleBackend :: + B.ExprBuilder t st fs -> + IO (SimpleBackend t st fs) +newSimpleBackend sym = + do as <- AS.initAssumptionStack (sym ^. B.exprCounter) + tryExtendConfig backendOptions (getConfiguration sym) + return SimpleBackend + { sbAssumptionStack = as + , sbExprBuilder = sym + } + +instance HasSymInterface (B.ExprBuilder t st fs) (SimpleBackend t st fs) where + backendGetSym = sbExprBuilder + +instance IsSymInterface (B.ExprBuilder t st fs) => + IsSymBackend (B.ExprBuilder t st fs) (SimpleBackend t st fs) where + + addDurableProofObligation bak a = + AS.addProofObligation a (sbAssumptionStack bak) + + addAssumption bak a = + case impossibleAssumption a of + Just rsn -> abortExecBecause rsn + Nothing -> AS.appendAssumptions (singleAssumption a) (sbAssumptionStack bak) + + addAssumptions bak ps = do + AS.appendAssumptions ps (sbAssumptionStack bak) + + collectAssumptions bak = + AS.collectAssumptions (sbAssumptionStack bak) + + getPathCondition bak = do + let sym = backendGetSym bak + ps <- AS.collectAssumptions (sbAssumptionStack bak) + assumptionsPred sym ps + + getProofObligations bak = do + AS.getProofObligations (sbAssumptionStack bak) + + clearProofObligations bak = do + AS.clearProofObligations (sbAssumptionStack bak) + + pushAssumptionFrame bak = do + AS.pushFrame (sbAssumptionStack bak) + + popAssumptionFrame bak ident = do + AS.popFrame ident (sbAssumptionStack bak) + + popAssumptionFrameAndObligations bak ident = do + AS.popFrameAndGoals ident (sbAssumptionStack bak) + + popUntilAssumptionFrame bak ident = do + void $ AS.popFramesUntil ident (sbAssumptionStack bak) + + saveAssumptionState bak = do + AS.saveAssumptionStack (sbAssumptionStack bak) + + restoreAssumptionState bak newstk = do + AS.restoreAssumptionStack newstk (sbAssumptionStack bak) diff --git a/src/Lang/Crucible/CFG/Common.hs b/src/Lang/Crucible/CFG/Common.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Common.hs @@ -0,0 +1,72 @@ +{- | +Module : Lang.Crucible.CFG.Common +Description : Common CFG datastructure definitions +Copyright : (c) Galois, Inc 2014-2016 +License : BSD3 +Maintainer : Joe Hendrix + +Data structures and operations that are common to both the +registerized and the SSA form CFG representations. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +module Lang.Crucible.CFG.Common + ( -- * Global variables + GlobalVar(..) + , freshGlobalVar + , BreakpointName(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Prettyprinter + +import Data.Parameterized.Classes +import Data.Parameterized.Nonce + +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- GlobalVar + +-- | A global variable. +data GlobalVar (tp :: CrucibleType) + = GlobalVar { globalNonce :: {-# UNPACK #-} !(Nonce GlobalNonceGenerator tp) + , globalName :: !Text + , globalType :: !(TypeRepr tp) + } + +instance TestEquality GlobalVar where + x `testEquality` y = globalNonce x `testEquality` globalNonce y + +instance OrdF GlobalVar where + x `compareF` y = globalNonce x `compareF` globalNonce y + +instance Show (GlobalVar tp) where + show = Text.unpack . globalName + +instance ShowF GlobalVar + +instance Pretty (GlobalVar tp) where + pretty = pretty . globalName + + +freshGlobalVar :: HandleAllocator + -> Text + -> TypeRepr tp + -> IO (GlobalVar tp) +freshGlobalVar halloc nm tp = do + nonce <- freshNonce (haCounter halloc) + return GlobalVar + { globalNonce = nonce + , globalName = nm + , globalType = tp + } + +newtype BreakpointName = BreakpointName { breakpointNameText :: Text } + deriving (Eq, Ord, Show) + +instance Pretty BreakpointName where + pretty = pretty . breakpointNameText diff --git a/src/Lang/Crucible/CFG/Core.hs b/src/Lang/Crucible/CFG/Core.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Core.hs @@ -0,0 +1,832 @@ +{- | +Module : Lang.Crucible.CFG.Core +Description : SSA-based control flow graphs +Copyright : (c) Galois, Inc 2014-2016 +License : BSD3 +Maintainer : Joe Hendrix + +Define a SSA-based control flow graph data structure using a side-effect free +expression syntax. + +Unlike usual SSA forms, we do not use phi-functions, but instead rely on an +argument-passing formulation for basic blocks. In this form, concrete values +are bound to formal parameters instead of using phi-functions that switch +on the place from which you jumped. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Lang.Crucible.CFG.Core + ( -- * CFG + CFG(..) + , SomeCFG(..) + , HasSomeCFG(..) + , AnyCFG(..) + , ppCFG + , ppCFG' + , cfgArgTypes + , cfgReturnType + , CFGPostdom + + -- * Blocks + , BlockMap + , getBlock + , extendBlockMap + + , BlockID(..) + , extendBlockID + , extendBlockID' + + , Block(..) + , blockLoc + , blockStmts + , withBlockTermStmt + , nextBlocks + + -- * Jump targets + , JumpTarget(..) + , extendJumpTarget + , jumpTargetID + , SwitchTarget(..) + , switchTargetID + , extendSwitchTarget + + -- * Statements + , StmtSeq(..) + , firstStmtLoc + , stmtSeqTermStmt + , Stmt(..) + , ppStmt + , nextStmtHeight + + , applyEmbeddingStmt + + , TermStmt(..) + , termStmtNextBlocks + + -- * Expressions + , Expr(..) + , Reg(..) + , extendReg + , lastReg + + -- * Re-exports + , module Lang.Crucible.Types + , module Lang.Crucible.CFG.Common + , module Data.Parameterized.Classes + , module Data.Parameterized.Some + ) where + +import Control.Applicative +import Control.Lens +import Data.Bimap (Bimap) +import Data.Maybe (fromMaybe) +import Data.Kind (Type) +import Data.Parameterized.Classes +import Data.Parameterized.Map (Pair(..)) +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.String +import Prettyprinter + +import What4.ProgramLoc +import What4.Symbol + +import Lang.Crucible.CFG.Common +import Lang.Crucible.CFG.Expr +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types +import Lang.Crucible.Utils.PrettyPrint + +#ifdef UNSAFE_OPS +-- We deliberately import Context.Unsafe as it is the only one that supports +-- the unsafe coerces between an index and its extension. +import Data.Parameterized.Context as Ctx hiding (Assignment) +import Data.Parameterized.Context.Unsafe as Ctx (Assignment) +import Unsafe.Coerce +#else +import Data.Parameterized.Context as Ctx +#endif + +------------------------------------------------------------------------ +-- Reg + +-- | A temporary register identifier introduced during translation. +-- These are unique to the current function. The `ctx` parameter +-- is a context containing the types of all the temporary registers +-- currently in scope, and the `tp` parameter indicates the type +-- of this register (which necessarily appears somewhere in `ctx`) +newtype Reg (ctx :: Ctx CrucibleType) (tp :: CrucibleType) = Reg { regIndex :: Ctx.Index ctx tp } + deriving (Eq, TestEquality, Ord, OrdF) + +instance Show (Reg ctx tp) where + show (Reg i) = '$' : show (indexVal i) + +instance ShowF (Reg ctx) + +instance Pretty (Reg ctx tp) where + pretty (Reg i) = pretty '$' <> pretty (indexVal i) + +instance ApplyEmbedding' Reg where + applyEmbedding' ctxe r = Reg $ applyEmbedding' ctxe (regIndex r) + +instance ExtendContext' Reg where + extendContext' diff r = Reg $ extendContext' diff (regIndex r) + +-- | Finds the value of the most-recently introduced register in scope. +lastReg :: KnownContext ctx => Reg (ctx ::> tp) tp +lastReg = Reg (nextIndex knownSize) + +-- | Extend the set of registers in scope for a given register value +-- without changing its index or type. +extendReg :: Reg ctx tp -> Reg (ctx ::> r) tp +extendReg = Reg . extendIndex . regIndex + +------------------------------------------------------------------------ +-- Expr + +-- | An expression is just an App applied to some registers. +newtype Expr ext (ctx :: Ctx CrucibleType) (tp :: CrucibleType) + = App (App ext (Reg ctx) tp) + +instance IsString (Expr ext ctx (StringType Unicode)) where + fromString = App . StringLit . fromString + +instance PrettyApp (ExprExtension ext) => Pretty (Expr ext ctx tp) where + pretty (App a) = ppApp pretty a + +ppAssignment :: Assignment (Reg ctx) args -> [Doc ann] +ppAssignment = toListFC pretty + +instance ( TraversableFC (ExprExtension ext) + ) => ApplyEmbedding' (Expr ext) where + applyEmbedding' ctxe (App e) = App (mapApp (applyEmbedding' ctxe) e) + +instance ( TraversableFC (ExprExtension ext) + ) => ExtendContext' (Expr ext) where + extendContext' diff (App e) = App (mapApp (extendContext' diff) e) + +------------------------------------------------------------------------ +-- BlockID + +-- | A `BlockID` uniquely identifies a block in a control-flow graph. +-- Each block has an associated context, indicating the formal arguments +-- it expects to find in registers from its calling locations. +newtype BlockID (blocks :: Ctx (Ctx CrucibleType)) (tp :: Ctx CrucibleType) + = BlockID { blockIDIndex :: Ctx.Index blocks tp } + deriving (Eq, Ord) + +instance TestEquality (BlockID blocks) where + testEquality (BlockID x) (BlockID y) = testEquality x y + +instance OrdF (BlockID blocks) where + compareF (BlockID x) (BlockID y) = compareF x y + +instance Pretty (BlockID blocks tp) where + pretty (BlockID i) = pretty '%' <> pretty (indexVal i) + +instance Show (BlockID blocks ctx) where + show (BlockID i) = '%' : show (indexVal i) + +instance ShowF (BlockID blocks) + +extendBlockID :: KnownDiff l r => BlockID l tp -> BlockID r tp +extendBlockID = BlockID . extendIndex . blockIDIndex + +extendBlockID' :: Diff l r -> BlockID l tp -> BlockID r tp +extendBlockID' e = BlockID . extendIndex' e . blockIDIndex + +------------------------------------------------------------------------ +-- JumpTarget + +-- | Target for jump and branch statements +data JumpTarget blocks ctx where + JumpTarget :: !(BlockID blocks args) -- BlockID to jump to + -> !(CtxRepr args) -- expected argument types + -> !(Assignment (Reg ctx) args) -- jump target actual arguments + -> JumpTarget blocks ctx + +instance Pretty (JumpTarget blocks ctx) where + pretty (JumpTarget tgt _ a) = pretty tgt <> parens (commas (ppAssignment a)) + +jumpTargetID :: JumpTarget blocks ctx -> Some (BlockID blocks) +jumpTargetID (JumpTarget tgt _ _) = Some tgt + +extendJumpTarget :: Diff blocks' blocks -> JumpTarget blocks' ctx -> JumpTarget blocks ctx +extendJumpTarget diff (JumpTarget b tps a) = JumpTarget (extendBlockID' diff b) tps a + +instance ApplyEmbedding (JumpTarget blocks) where + applyEmbedding ctxe (JumpTarget dest tys args) = + JumpTarget dest tys (fmapFC (applyEmbedding' ctxe) args) + +instance ExtendContext (JumpTarget blocks) where + extendContext diff (JumpTarget dest tys args) = + JumpTarget dest tys (fmapFC (extendContext' diff) args) + +------------------------------------------------------------------------ +-- SwitchTarget + +-- | Target for a switch statement. +data SwitchTarget blocks ctx tp where + SwitchTarget :: !(BlockID blocks (args ::> tp)) -- BlockID to jump to + -> !(CtxRepr args) -- expected argument types + -> !(Assignment (Reg ctx) args) -- switch target actual arguments + -> SwitchTarget blocks ctx tp + +switchTargetID :: SwitchTarget blocks ctx tp -> Some (BlockID blocks) +switchTargetID (SwitchTarget tgt _ _) = Some tgt + +ppCase :: String -> SwitchTarget blocks ctx tp -> Doc ann +ppCase nm (SwitchTarget tgt _ a) = + pretty nm <+> pretty "->" <+> pretty tgt <> parens (commas (ppAssignment a)) + +extendSwitchTarget :: Diff blocks' blocks + -> SwitchTarget blocks' ctx tp + -> SwitchTarget blocks ctx tp +extendSwitchTarget diff (SwitchTarget b tps a) = + SwitchTarget (extendBlockID' diff b) tps a + +instance ApplyEmbedding' (SwitchTarget blocks) where + applyEmbedding' ctxe (SwitchTarget dest tys args) = + SwitchTarget dest tys (fmapFC (applyEmbedding' ctxe) args) + +instance ExtendContext' (SwitchTarget blocks) where + extendContext' diff (SwitchTarget dest tys args) = + SwitchTarget dest tys (fmapFC (extendContext' diff) args) + + +------------------------------------------------------------------------ +-- Stmt + +-- | A sequential statement that does not affect the +-- program location within the current block or leave the current +-- block. +data Stmt ext (ctx :: Ctx CrucibleType) (ctx' :: Ctx CrucibleType) where + -- Assign the value of a register + SetReg :: !(TypeRepr tp) + -> !(Expr ext ctx tp) + -> Stmt ext ctx (ctx ::> tp) + + -- Assign a register via an extension statement + ExtendAssign :: !(StmtExtension ext (Reg ctx) tp) + -> Stmt ext ctx (ctx ::> tp) + + -- Statement used for evaluating function calls + CallHandle :: !(TypeRepr ret) -- The type of the return value(s) + -> !(Reg ctx (FunctionHandleType args ret)) -- The function handle to call + -> !(CtxRepr args) -- The expected types of the arguments + -> !(Assignment (Reg ctx) args) -- The actual arguments to the call + -> Stmt ext ctx (ctx ::> ret) + + -- Print a message out to the console + Print :: !(Reg ctx (StringType Unicode)) -> Stmt ext ctx ctx + + -- Read a global variable. + ReadGlobal :: !(GlobalVar tp) + -> Stmt ext ctx (ctx ::> tp) + + -- Write to a global variable. + WriteGlobal :: !(GlobalVar tp) + -> !(Reg ctx tp) + -> Stmt ext ctx ctx + + -- Create a fresh constant + FreshConstant :: !(BaseTypeRepr bt) + -> !(Maybe SolverSymbol) + -> Stmt ext ctx (ctx ::> BaseToType bt) + + -- Create a fresh floating-point constant + FreshFloat :: !(FloatInfoRepr fi) + -> !(Maybe SolverSymbol) + -> Stmt ext ctx (ctx ::> FloatType fi) + + -- Create a fresh natural number constant + FreshNat :: !(Maybe SolverSymbol) + -> Stmt ext ctx (ctx ::> NatType) + + -- Allocate a new reference cell + NewRefCell :: !(TypeRepr tp) + -> !(Reg ctx tp) + -> Stmt ext ctx (ctx ::> ReferenceType tp) + + -- Allocate a new, unassigned reference cell + NewEmptyRefCell :: !(TypeRepr tp) + -> Stmt ext ctx (ctx ::> ReferenceType tp) + + -- Read the current value of a reference cell + ReadRefCell :: !(Reg ctx (ReferenceType tp)) + -> Stmt ext ctx (ctx ::> tp) + + -- Write the current value of a reference cell + WriteRefCell :: !(Reg ctx (ReferenceType tp)) + -> !(Reg ctx tp) + -> Stmt ext ctx ctx + + -- Deallocate the storage associated with a reference cell + DropRefCell :: !(Reg ctx (ReferenceType tp)) + -> Stmt ext ctx ctx + + -- Assert a boolean condition. If the condition fails, print the given string. + Assert :: !(Reg ctx BoolType) -> !(Reg ctx (StringType Unicode)) -> Stmt ext ctx ctx + + -- Assume a boolean condition, remembering the given string as the 'reason' for this assumption. + Assume :: !(Reg ctx BoolType) -> !(Reg ctx (StringType Unicode)) -> Stmt ext ctx ctx + +------------------------------------------------------------------------ +-- TermStmt + +data TermStmt blocks (ret :: CrucibleType) (ctx :: Ctx CrucibleType) where + -- Jump to the given jump target + Jump :: !(JumpTarget blocks ctx) + -> TermStmt blocks ret ctx + + -- Branch on condition. If true, jump to the first jump target; otherwise + -- jump to the second jump target. + Br :: !(Reg ctx BoolType) + -> !(JumpTarget blocks ctx) + -> !(JumpTarget blocks ctx) + -> TermStmt blocks ret ctx + + -- Switch on whether this is a maybe value. Jump to the switch target if + -- the maybe value is a "Some". Otherwise (if "Nothing"), jump to the jump target. + MaybeBranch :: !(TypeRepr tp) + -> !(Reg ctx (MaybeType tp)) + -> !(SwitchTarget blocks ctx tp) + -> !(JumpTarget blocks ctx) + -> TermStmt blocks rtp ctx + + -- Switch on a variant value. Examine the tag of the variant + -- and jump to the appropriate switch target. + VariantElim :: !(CtxRepr varctx) + -> !(Reg ctx (VariantType varctx)) + -> !(Assignment (SwitchTarget blocks ctx) varctx) + -> TermStmt blocks ret ctx + + -- Return from function, providing the return value(s). + Return :: !(Reg ctx ret) + -> TermStmt blocks ret ctx + + -- End block with a tail call. + TailCall :: !(Reg ctx (FunctionHandleType args ret)) + -> !(CtxRepr args) + -> !(Assignment (Reg ctx) args) + -> TermStmt blocks ret ctx + + -- Block ends with an error. + ErrorStmt :: !(Reg ctx (StringType Unicode)) -> TermStmt blocks ret ctx + +#ifndef UNSAFE_OPS +extendTermStmt :: Diff blocks' blocks -> TermStmt blocks' ret ctx -> TermStmt blocks ret ctx +extendTermStmt diff (Jump tgt) = Jump (extendJumpTarget diff tgt) +extendTermStmt diff (Br c x y) = Br c (extendJumpTarget diff x) (extendJumpTarget diff y) +extendTermStmt diff (MaybeBranch tp c x y) = + MaybeBranch tp c (extendSwitchTarget diff x) (extendJumpTarget diff y) +extendTermStmt diff (VariantElim ctx e asgn) = + VariantElim ctx e (fmapFC (extendSwitchTarget diff) asgn) +extendTermStmt _diff (Return e) = Return e +extendTermStmt _diff (TailCall h tps args) = TailCall h tps args +extendTermStmt _diff (ErrorStmt e) = ErrorStmt e +#endif + +-- | Return the set of possible next blocks from a TermStmt +termStmtNextBlocks :: TermStmt b ret ctx -> Maybe [Some (BlockID b)] +termStmtNextBlocks s0 = + case s0 of + Jump tgt -> Just [ jumpTargetID tgt ] + Br _ x y -> Just [ jumpTargetID x, jumpTargetID y ] + MaybeBranch _ _ x y -> Just [ switchTargetID x, jumpTargetID y ] + VariantElim _ _ a -> Just (toListFC switchTargetID a) + Return _ -> Nothing + TailCall _ _ _ -> Nothing + ErrorStmt _ -> Just [] + +instance Pretty (TermStmt blocks ret ctx) where + pretty s = + case s of + Jump b -> pretty "jump" <+> pretty b + Br e x y -> pretty "br" <+> pretty e <+> pretty x <+> pretty y + MaybeBranch _ e j n -> + vcat + [ pretty "maybeBranch" <+> pretty e <+> lbrace + , indent 2 $ + vcat [ ppCase "Just" j + , pretty "Nothing ->" <+> pretty n + , rbrace + ] + ] + VariantElim _ e asgn -> + let branches = + [ f (show i) <> semi + | i <- [(0::Int) .. ] + | f <- toListFC (\tgt nm -> ppCase nm tgt) asgn + ] in + vcat + [ pretty "vswitch" <+> pretty e <+> lbrace + , indent 2 (vcat branches) + , rbrace + ] + Return e -> + pretty "return" + <+> pretty e + TailCall h _ args -> + pretty "tailCall" + <+> pretty h + <+> parens (commas (ppAssignment args)) + ErrorStmt msg -> + pretty "error" <+> pretty msg + + +applyEmbeddingStmt :: forall ext ctx ctx' sctx. + TraverseExt ext => + CtxEmbedding ctx ctx' -> + Stmt ext ctx sctx -> + Pair (Stmt ext ctx') (CtxEmbedding sctx) +applyEmbeddingStmt ctxe stmt = + case stmt of + SetReg tp e -> Pair (SetReg tp (applyEmbedding' ctxe e)) + (extendEmbeddingBoth ctxe) + + ExtendAssign estmt -> + Pair (ExtendAssign (fmapFC (Ctx.applyEmbedding' ctxe) estmt)) + (Ctx.extendEmbeddingBoth ctxe) + + CallHandle ret hdl tys args -> + Pair (CallHandle ret (reg hdl) tys (fmapFC reg args)) + (extendEmbeddingBoth ctxe) + + Print str -> Pair (Print (reg str)) ctxe + + ReadGlobal var -> Pair (ReadGlobal var) + (extendEmbeddingBoth ctxe) + + WriteGlobal var r -> Pair (WriteGlobal var (reg r)) ctxe + + FreshConstant bt nm -> Pair (FreshConstant bt nm) + (Ctx.extendEmbeddingBoth ctxe) + + FreshFloat fi nm -> Pair (FreshFloat fi nm) + (Ctx.extendEmbeddingBoth ctxe) + + FreshNat nm -> Pair (FreshNat nm) (Ctx.extendEmbeddingBoth ctxe) + + NewRefCell tp r -> Pair (NewRefCell tp (reg r)) + (Ctx.extendEmbeddingBoth ctxe) + NewEmptyRefCell tp -> Pair (NewEmptyRefCell tp) + (Ctx.extendEmbeddingBoth ctxe) + ReadRefCell r -> Pair (ReadRefCell (reg r)) + (Ctx.extendEmbeddingBoth ctxe) + WriteRefCell r r' -> Pair (WriteRefCell (reg r) (reg r')) ctxe + DropRefCell r -> Pair (DropRefCell (reg r)) ctxe + Assert b str -> Pair (Assert (reg b) (reg str)) ctxe + Assume b str -> Pair (Assume (reg b) (reg str)) ctxe + where + reg :: forall tp. Reg ctx tp -> Reg ctx' tp + reg = applyEmbedding' ctxe + + +instance ApplyEmbedding (TermStmt blocks ret) where + applyEmbedding :: forall ctx ctx'. + CtxEmbedding ctx ctx' + -> TermStmt blocks ret ctx + -> TermStmt blocks ret ctx' + applyEmbedding ctxe term = + case term of + Jump jt -> Jump (apC jt) + Br b jtl jtr -> Br (apC' b) (apC jtl) (apC jtr) + MaybeBranch tp b swt jt -> MaybeBranch tp (apC' b) (apC' swt) (apC jt) + VariantElim repr r targets -> VariantElim repr (apC' r) (fmapFC apC' targets) + Return r -> Return (apC' r) + TailCall hdl tys args -> TailCall (apC' hdl) tys (fmapFC apC' args) + ErrorStmt r -> ErrorStmt (apC' r) + where + apC' :: forall f v. ApplyEmbedding' f => f ctx v -> f ctx' v + apC' = applyEmbedding' ctxe + + apC :: forall f. ApplyEmbedding f => f ctx -> f ctx' + apC = applyEmbedding ctxe + +instance ExtendContext (TermStmt blocks ret) where + extendContext :: forall ctx ctx'. + Diff ctx ctx' + -> TermStmt blocks ret ctx + -> TermStmt blocks ret ctx' + extendContext diff term = + case term of + Jump jt -> Jump (extC jt) + Br b jtl jtr -> Br (extC' b) (extC jtl) (extC jtr) + MaybeBranch tp b swt jt -> MaybeBranch tp (extC' b) (extC' swt) (extC jt) + VariantElim repr r targets -> VariantElim repr (extC' r) (fmapFC extC' targets) + Return r -> Return (extC' r) + TailCall hdl tys args -> TailCall (extC' hdl) tys (fmapFC extC' args) + ErrorStmt r -> ErrorStmt (extC' r) + where + extC' :: forall f v. ExtendContext' f => f ctx v -> f ctx' v + extC' = extendContext' diff + + extC :: forall f. ExtendContext f => f ctx -> f ctx' + extC = extendContext diff + + +------------------------------------------------------------------------ +-- StmtSeq + +-- | A sequence of straight-line program statements that end with +-- a terminating statement (return, jump, etc). +data StmtSeq ext blocks (ret :: CrucibleType) ctx where + ConsStmt :: !ProgramLoc + -> !(Stmt ext ctx ctx') + -> !(StmtSeq ext blocks ret ctx') + -> StmtSeq ext blocks ret ctx + TermStmt :: !ProgramLoc + -> !(TermStmt blocks ret ctx) + -> (StmtSeq ext blocks ret ctx) + +-- | Return the location of a statement. +firstStmtLoc :: StmtSeq ext b r ctx -> ProgramLoc +firstStmtLoc (ConsStmt pl _ _) = pl +firstStmtLoc (TermStmt pl _) = pl + +-- | A lens-like operation that gives one access to program location and term statement, +-- and allows the terminal statement to be replaced with an arbitrary sequence of +-- statements. +stmtSeqTermStmt :: Functor f + => (forall ctx + . (ProgramLoc, TermStmt b ret ctx) + -> f (StmtSeq ext b' ret ctx)) + -> StmtSeq ext b ret args + -> f (StmtSeq ext b' ret args) +stmtSeqTermStmt f (ConsStmt l s t) = ConsStmt l s <$> stmtSeqTermStmt f t +stmtSeqTermStmt f (TermStmt p t) = f (p, t) + +ppReg :: Size ctx -> Doc ann +ppReg h = pretty "$" <> pretty (sizeInt h) + +nextStmtHeight :: Size ctx -> Stmt ext ctx ctx' -> Size ctx' +nextStmtHeight h s = + case s of + SetReg{} -> incSize h + ExtendAssign{} -> incSize h + CallHandle{} -> incSize h + Print{} -> h + ReadGlobal{} -> incSize h + WriteGlobal{} -> h + FreshConstant{} -> Ctx.incSize h + FreshFloat{} -> Ctx.incSize h + FreshNat{} -> Ctx.incSize h + NewRefCell{} -> Ctx.incSize h + NewEmptyRefCell{} ->Ctx.incSize h + ReadRefCell{} -> Ctx.incSize h + WriteRefCell{} -> h + DropRefCell{} -> h + Assert{} -> h + Assume{} -> h + +ppStmt :: PrettyExt ext => Size ctx -> Stmt ext ctx ctx' -> Doc ann +ppStmt r s = + case s of + SetReg _ e -> ppReg r <+> pretty "=" <+> pretty e + ExtendAssign s' -> ppReg r <+> pretty "=" <+> ppApp pretty s' + CallHandle _ h _ args -> + ppReg r <+> pretty "= call" + <+> pretty h <> parens (commas (ppAssignment args)) + <> pretty ";" + Print msg -> ppFn "print" [ pretty msg ] + ReadGlobal v -> pretty "read" <+> ppReg r <+> pretty v + WriteGlobal v e -> pretty "write" <+> pretty v <+> pretty e + -- TODO: replace viaShow once we have instance Pretty SolverSymbol + FreshConstant bt nm -> ppReg r <+> pretty "=" <+> pretty "fresh" <+> pretty bt <+> maybe mempty viaShow nm + FreshFloat fi nm -> ppReg r <+> pretty "=" <+> pretty "fresh-float" <+> pretty fi <+> maybe mempty viaShow nm + FreshNat nm -> ppReg r <+> pretty "=" <+> pretty "fresh-nat" <+> maybe mempty viaShow nm + NewRefCell _ e -> ppReg r <+> pretty "=" <+> ppFn "newref" [ pretty e ] + NewEmptyRefCell tp -> ppReg r <+> pretty "=" <+> ppFn "emptyref" [ pretty tp ] + ReadRefCell e -> ppReg r <+> pretty "= !" <> pretty e + WriteRefCell r1 r2 -> pretty r1 <+> pretty ":=" <+> pretty r2 + DropRefCell r1 -> pretty "drop" <+> pretty r1 + Assert c e -> ppFn "assert" [ pretty c, pretty e ] + Assume c e -> ppFn "assume" [ pretty c, pretty e ] + +prefixLineNum :: Bool -> ProgramLoc -> Doc ann -> Doc ann +prefixLineNum True pl d = vcat [pretty "%" <+> ppNoFileName (plSourceLoc pl), d] +prefixLineNum False _ d = d + +ppStmtSeq :: PrettyExt ext => Bool -> Size ctx -> StmtSeq ext blocks ret ctx -> Doc ann +ppStmtSeq ppLineNum h (ConsStmt pl s r) = + vcat + [ prefixLineNum ppLineNum pl (ppStmt h s) + , ppStmtSeq ppLineNum (nextStmtHeight h s) r + ] +ppStmtSeq ppLineNum _ (TermStmt pl s) = + prefixLineNum ppLineNum pl (pretty s) + + +#ifndef UNSAFE_OPS +extendStmtSeq :: Diff blocks' blocks -> StmtSeq ext blocks' ret ctx -> StmtSeq ext blocks ret ctx +extendStmtSeq diff (ConsStmt p s l) = ConsStmt p s (extendStmtSeq diff l) +extendStmtSeq diff (TermStmt p s) = TermStmt p (extendTermStmt diff s) +#endif + + +instance TraverseExt ext => ApplyEmbedding (StmtSeq ext blocks ret) where + applyEmbedding ctxe (ConsStmt loc stmt rest) = + case applyEmbeddingStmt ctxe stmt of + Pair stmt' ctxe' -> ConsStmt loc stmt' (applyEmbedding ctxe' rest) + applyEmbedding ctxe (TermStmt loc term) = + TermStmt loc (applyEmbedding ctxe term) + + + +------------------------------------------------------------------------ +-- CFGPostdom + +-- | Postdominator information about a CFG. The assignment maps each block +-- to the postdominators of the given block. The postdominators are ordered +-- with nearest postdominator first. +type CFGPostdom blocks = Assignment (Const [Some (BlockID blocks)]) blocks + +emptyCFGPostdomInfo :: Size blocks -> CFGPostdom blocks +emptyCFGPostdomInfo sz = Ctx.replicate sz (Const []) + + +------------------------------------------------------------------------ +-- Block + +-- | A basic block within a function. +data Block ext (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType) ctx + = Block { blockID :: !(BlockID blocks ctx) + -- ^ The unique identifier of this block + , blockInputs :: !(CtxRepr ctx) + -- ^ The expected types of the formal arguments to this block + , _blockStmts :: !(StmtSeq ext blocks ret ctx) + -- ^ The sequence of statements in this block + } + +blockStmts :: Simple Lens (Block ext b r c) (StmtSeq ext b r c) +blockStmts = lens _blockStmts (\b s -> b { _blockStmts = s }) + +-- | Return location of start of block. +blockLoc :: Block ext blocks ret ctx -> ProgramLoc +blockLoc b = firstStmtLoc (b^.blockStmts) + +-- | Get the terminal statement of a basic block. This is implemented +-- in a CPS style due to the block context. +withBlockTermStmt :: Block ext blocks ret args + -> (forall ctx . ProgramLoc -> TermStmt blocks ret ctx -> r) + -> r +withBlockTermStmt b f = getConst (stmtSeqTermStmt (Const . uncurry f) (b^.blockStmts)) + +nextBlocks :: Block ext b r a -> [Some (BlockID b)] +nextBlocks b = + withBlockTermStmt b (\_ s -> fromMaybe [] (termStmtNextBlocks s)) + + +blockInputCount :: Block ext blocks ret ctx -> Size ctx +blockInputCount b = size (blockInputs b) + +ppBlock :: PrettyExt ext + => Bool + -- ^ Print line numbers. + -> Bool + -- ^ Print block args. Note that you can infer the number + -- of block args from the first SSA temp register assigned + -- to in the block: if the block has @n@ args, then the + -- first register it assigns to will be @$n@. + -> Maybe (CFGPostdom blocks) + -- ^ Optionally print postdom info. + -> Block ext blocks ret ctx + -- ^ Block to print. + -> Doc ann +ppBlock ppLineNumbers ppBlockArgs mPda b = do + let stmts = ppStmtSeq ppLineNumbers (blockInputCount b) (b^.blockStmts) + let mPostdom = flip fmap mPda $ \ pda -> + let Const pd = pda ! blockIDIndex (blockID b) + in if Prelude.null pd + then pretty "% no postdom" + else pretty "% postdom" <+> hsep (viewSome pretty <$> pd) + let numArgs = lengthFC (blockInputs b) + let argList = [ pretty '$' <> pretty n | n <- [0 .. numArgs-1] ] + let args = encloseSep lparen rparen comma argList + let block = pretty (blockID b) <> + if ppBlockArgs then args else mempty + let body = case mPostdom of + Nothing -> stmts + Just postdom -> vcat [stmts, postdom] + vcat [block, indent 2 body] + +instance PrettyExt ext => Show (Block ext blocks ret args) where + show blk = show $ ppBlock False False Nothing blk + +instance PrettyExt ext => ShowF (Block ext blocks ret) + +#ifndef UNSAFE_OPS +extendBlock :: Block ext blocks ret ctx -> Block ext (blocks ::> new) ret ctx +extendBlock b = + Block { blockID = extendBlockID (blockID b) + , blockInputs = blockInputs b + , _blockStmts = extendStmtSeq knownDiff (b^.blockStmts) + } +#endif + +------------------------------------------------------------------------ +-- BlockMap + +-- | A mapping from block indices to CFG blocks +type BlockMap ext blocks ret = Assignment (Block ext blocks ret) blocks + +getBlock :: BlockID blocks args + -> BlockMap ext blocks ret + -> Block ext blocks ret args +getBlock (BlockID i) m = m Ctx.! i + +extendBlockMap :: Assignment (Block ext blocks ret) b + -> Assignment (Block ext (blocks ::> args) ret) b +#ifdef UNSAFE_OPS +extendBlockMap = unsafeCoerce +#else +extendBlockMap = fmapFC extendBlock +#endif +------------------------------------------------------------------------ +-- CFG + +-- | A CFG consists of: +-- +-- * a function handle, uniquely identifying the function this CFG +-- implements; +-- +-- * a block map, representing the main CFG data structure; +-- +-- * and the identifier of the function entry point. +-- +-- The @blocks@ type parameter maps each block identifier to the +-- formal arguments it expects. The @init@ type parameter identifies +-- the formal arguments of the function represented by this control-flow graph, +-- which correspond to the formal arguments of the CFG entry point. +-- The @ret@ type parameter indicates the return type of the function. +data CFG (ext :: Type) + (blocks :: Ctx (Ctx CrucibleType)) + (init :: Ctx CrucibleType) + (ret :: CrucibleType) + = CFG { cfgHandle :: FnHandle init ret + , cfgBlockMap :: !(BlockMap ext blocks ret) + , cfgEntryBlockID :: !(BlockID blocks init) + , cfgBreakpoints :: !(Bimap BreakpointName (Some (BlockID blocks))) + } + +cfgArgTypes :: CFG ext blocks init ret -> CtxRepr init +cfgArgTypes g = handleArgTypes (cfgHandle g) + +cfgReturnType :: CFG ext blocks init ret -> TypeRepr ret +cfgReturnType g = handleReturnType (cfgHandle g) + +-- | Class for types that embed a CFG of some sort. +class HasSomeCFG f ext init ret | f -> ext, f -> init, f -> ret where + getCFG :: f b -> SomeCFG ext init ret + +instance PrettyExt ext => Show (CFG ext blocks init ret) where + show g = show (ppCFG True g) + +-- | Pretty print a CFG. +ppCFG :: PrettyExt ext + => Bool -- ^ Flag indicates if we should print line numbers + -> CFG ext blocks init ret + -> Doc ann +ppCFG lineNumbers g = ppCFG' lineNumbers (emptyCFGPostdomInfo sz) g + where sz = size (cfgBlockMap g) + +-- | Pretty print CFG with postdom information. +ppCFG' :: PrettyExt ext + => Bool -- ^ Flag indicates if we should print line numbers + -> CFGPostdom blocks + -> CFG ext blocks init ret + -> Doc ann +ppCFG' lineNumbers pdInfo g = vcat (toListFC (ppBlock lineNumbers blockArgs (Just pdInfo)) (cfgBlockMap g)) + where blockArgs = False + +-- | Control flow graph with some blocks. This data type closes +-- existentially over the @blocks@ type parameter. +data SomeCFG ext (init :: Ctx CrucibleType) (ret :: CrucibleType) where + SomeCFG :: CFG ext blocks init ret -> SomeCFG ext init ret + +instance PrettyExt ext => Show (SomeCFG ext i r) + where show cfg = case cfg of SomeCFG c -> show c + +-- | Control flow graph. This data type closes existentially +-- over all the type parameters except @ext@. +data AnyCFG ext where + AnyCFG :: CFG ext blocks init ret + -> AnyCFG ext + +instance PrettyExt ext => Show (AnyCFG ext) where + show cfg = case cfg of AnyCFG c -> show c diff --git a/src/Lang/Crucible/CFG/EarlyMergeLoops.hs b/src/Lang/Crucible/CFG/EarlyMergeLoops.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/EarlyMergeLoops.hs @@ -0,0 +1,871 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.CFG.EarlyMergeLoops +-- Description : Provides transformations on pre-SSA CFGs +-- Copyright : (c) Galois, Inc 2020 +-- License : BSD3 +-- Maintainer : +-- Stability : experimental +-- +-- This modules exposes a transformation that attempts to ensure that loop branches +-- are post-dominated by nodes in the loop. +-- +-- The module is organized into 3 main components: +-- 1. An analysis that computes the natural loops of a CFG; +-- 2. An analysis that inserts postdominators into loops that have +-- "early exits" (and hence have postdominators outside the loop); +-- 3. A "fixup" pass that ensures that, in the transformed CFG, all +-- values are well defined along all (new) paths. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Lang.Crucible.CFG.EarlyMergeLoops + ( earlyMergeLoops + ) where + +import Control.Monad (when, (>=>)) +import Control.Applicative ((<**>)) +import qualified Data.Graph.Inductive as G +import qualified Data.Foldable as Fold +import Data.Kind +import Data.List (nub, minimumBy) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq ((<|), fromList) +import Data.String (fromString) + +import What4.ProgramLoc (Position(..), Posd(..)) + +import Lang.Crucible.CFG.Expr +import Lang.Crucible.CFG.Reg +import Lang.Crucible.Panic +import Lang.Crucible.Types + +-------------------------- +-- | Natural Loop Analysis +-------------------------- + +-- | This structure identifies natural loops. Natural loops are either +-- disjoint from each other, nested, or they share the same header. +data LoopInfo s = LoopInfo + { liFooter :: !(BlockID s) + -- ^ This is the block with a backedge (to the header) + , liHeader :: !(BlockID s) + -- ^ This is the destination of the backedge. + , liMembers :: !(Set (BlockID s)) + -- ^ The loop members, which is the set of nodes that can reach the footer + -- without going through the header. + , liEarlyExits :: ![CFGEdge s] + -- ^ An exiting edge is an edge from a node in the loop to an edge + -- not in the loop. An early exit is such an edge from a node that + -- is not the footer node. + , liFooterIn :: ![CFGEdge s] + -- ^ All the edges to the footer + , liDominators :: ![BlockID s] + -- ^ The dominators of the loop header. + } deriving (Eq, Show) +type CFGEdge s = (BlockID s, BlockID s) + +-- | Detect all loops in a cfg. +-- The assumption is that two backedges in a cfg will have distinct destination blocks. +-- If this assumption does not hold, then return the empty list. +cfgLoops :: CFG ext s init ret -> [LoopInfo s] +cfgLoops cfg + | distinct = lis + | otherwise = [] + where + (nm, gr) = blocksGraph (cfgBlocks cfg) + root = toNode (blockID (cfgEntryBlock cfg)) + ls = loops root gr + lis = mkLoopInfo <$> ls + distinct = length (nub (liHeader <$> lis)) == length lis + + mkLoopInfo ((footer, header, _), members) = + LoopInfo + { liFooter = toBlockID footer + , liHeader = toBlockID header + , liMembers = Set.map toBlockID members + , liEarlyExits = [ (toBlockID i, toBlockID j) | (i,j) <- exits members, i /= footer ] + , liFooterIn = [ (toBlockID j, toBlockID footer) | j <- G.pre gr footer ] + , liDominators = maybe [] (fmap toBlockID) $ lookup header (G.dom gr root) + } + + toBlockID n = nm Map.! n + + exits bs = [ (i, j) | i <- Set.toList bs, j <- G.suc gr i, j `Set.notMember` bs ] + +-- | Is li1 nested in li2 +isNested :: LoopInfo s -> LoopInfo s -> Ordering +isNested li1 li2 + | liHeader li2 `elem` liDominators li1 = LT + | otherwise = EQ + +-- | Return all loops in @g@, which are edges from a node in g to a +-- dominator of that node. +loops :: G.Node -- ^ entry node + -> G.UGr -- ^ the graph + -> [(G.LEdge (), Set G.Node)] +loops root g = [ (e, loopMembers g dominators header) | e@(_,header,_) <- edges ] + where + edges = loop dominators g =<< G.nodes g + dominators = Map.fromList $ G.dom g root + +-- | Return any edges from @n@ to a dominator of @n@, @n'@. The edge +-- @n@ to @n'@ is a loop. +loop :: Map.Map G.Node [G.Node] -- ^ Dominators + -> G.UGr -- ^ The graph itself + -> G.Node -- ^ The root node to inspect for backedges + -> [G.LEdge ()] -- ^ A loop is an edge to a dominator +loop domMap g n = + -- A back edge (loop) is an edge from n -> n' where n' dominates n + [ (n, n', ()) | n' <- G.suc g n, n /= n', n' `elem` Map.findWithDefault [] n domMap ] + +-- | The members of a loop are just those nodes dominated by the +-- header that can reach the header again +loopMembers :: G.UGr -> Map.Map G.Node [G.Node] -> G.Node -> Set G.Node +loopMembers g doms header = + Set.fromList members + where + fromHeader = G.reachable header g + members = [ x | x <- fromHeader, header `elem` G.reachable x g, headerDominates x ] + headerDominates n + | Just ds <- Map.lookup n doms + = header `elem` ds + | otherwise + = False + +-- | View a blockID as a node +toNode :: BlockID s -> G.Node +toNode i = + case i of + LabelID l -> fromIntegral $ indexValue $ labelId l + LambdaID l -> fromIntegral $ indexValue $ lambdaId l + +-- | Compute the successor nodes of this block +blockSuccessors :: Block ext s ret -> [G.Node] +blockSuccessors b = + maybe [] (map toNode) $ termNextLabels (pos_val (blockTerm b)) + +-- | Returns the edges from this block to its successors +blockEdges :: Block ext s ret -> [G.LEdge ()] +blockEdges b = + mkEdge (toNode (blockID b)) <$> blockSuccessors b + where + mkEdge x y = (x, y, ()) + +blocksGraph :: [Block ext s ret] -> (Map.Map G.Node (BlockID s), G.UGr) +blocksGraph blocks = (m, G.mkGraph ((,()) <$> nodes) edges) + where + nodes = toNode . blockID <$> blocks + m = Map.fromList (zip nodes (blockID <$> blocks)) + edges = blockEdges =<< blocks + +----------------------------------------- +-- | Undefined Value Fixup Transformation +----------------------------------------- + +-- | A PartialValue of type @t@ closes over a register of type @Maybe t@ +type ValueToPartialMap s = MapF.MapF (Value s) (PartialValue s) +newtype PartialValue s tp = PartialValue { getPartial :: Reg s (MaybeType tp) } + +type AtomSubst s = MapF.MapF (Atom s :: CrucibleType -> Type) + (Atom s :: CrucibleType -> Type) +type AtomPair s = MapF.Pair (Atom s :: CrucibleType -> Type) + (Atom s :: CrucibleType -> Type) + +-- | Undefined Value Fixup pass +-- The merge-block insertion process introduces infeasible paths along which +-- some registers may be undefined: this will later be interpreted as a block +-- input in the SSA transformation. To avoid this, we introduce a pass to +-- replace registers/atoms that may be undefined along some path with a partial +-- register (i.e. of type Maybe t). +-- +-- Assuming that the input CFG has no paths along which a value is +-- read before being written, the paths along which the reference is +-- read but never written are a subset of the infeasible paths. +lowerUndefPass :: (Monad m, TraverseExt ext) + => NonceGenerator m s + -> Label s + -> CFG ext s init ret + -> m (CFG ext s init ret) +lowerUndefPass ng rootLabel cfg = + do (pvals, refInits) <- mkPartialRegMap ng cfg + + let root' = mkBlock (blockID root) (blockExtraInputs root) (blockStmts root <> refInits) (blockTerm root) + let lower blk + | blockID blk == LabelID rootLabel + = return root' + | otherwise + = lowerBlock ng pvals blk + + blks' <- mapM lower (cfgBlocks cfg) + let cfg' = cfg { cfgBlocks = blks' } + return cfg' + where + root = fromMaybe err $ findBlock cfg rootLabel + err = panic "EarlyMergeLoops.lowerUndefPass" + [ "Root block not found in cfg" ] + +-- | Fixup the reads and writes in a block. This means, for each value in the domain +-- of the @ValueToPartialMap@ argument, +-- 1. If the value is read, then find the associated partial value register and read that instead +-- 2. Dually, if the value is written, then write that value to the associated partial value register. +lowerBlock :: forall s m ext ret + . (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> Block ext s ret + -> m (Block ext s ret) +lowerBlock ng pvals blk = + do -- If this is a lambda block, treat the associated atom as a write to that atom. + initInputs <- lowerBlockIDValues ng pvals blk + -- Dually, any values passed to a successor should be treated as reads + (preOutput, loweredTerm) <- lowerTermStmtValues ng pvals blk + -- Fix the reads and writes in the body of this block + lowered <- concatMapSeqM (lowerReads >=> concatMapSeqM lowerWrites) (blockStmts blk) + return $ mkBlock (blockID blk) (blockExtraInputs blk) (initInputs <> lowered <> preOutput) loweredTerm + where + lowerWrites = lowerValueWrites ng pvals + lowerReads = lowerValueReads ng pvals + + concatMapSeqM :: Monad m => (a -> m (Seq b)) -> Seq a -> m (Seq b) + concatMapSeqM f seq0 = + Fold.foldrM (\s ss -> f s <**> pure (<> ss)) mempty seq0 + +-- | The atom in a lambda ID is essentially an 'atom definition', so +-- we need to check if this lambda's atom needs to be 'lowered'. +lowerBlockIDValues :: forall s m ext ret + . (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> Block ext s ret + -> m (Seq (Posd (Stmt ext s))) +lowerBlockIDValues ng pvals blk = + case blockID blk of + LambdaID (lambdaAtom -> a) + | Just (getPartial -> pr) <- MapF.lookup (AtomValue a) pvals -> + do pa <- freshAtom ng (atomPosition a) (MaybeRepr (typeOfAtom a)) + let setPa = Posd (atomPosition a) (DefineAtom pa (EvalApp (JustValue (typeOfAtom a) a))) + setPr = Posd (atomPosition a) (SetReg pr pa) + return $ Seq.fromList [ setPa, setPr ] + | otherwise -> + -- Not in our list of values to lower + return mempty + LabelID {} -> + -- No atoms defined + return mempty + +-- | Jumping to a block with a value a la Output is akin to +-- 'reading' the atom, so if we already lifted the original value +-- of type T to a (Maybe T), we need to convert it back to a T +-- here. +lowerTermStmtValues :: forall s m ext ret + . (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> Block ext s ret + -> m (Seq (Posd (Stmt ext s)), Posd (TermStmt s ret)) +lowerTermStmtValues ng pvals blk = + case pos_val (blockTerm blk) of + Output ll a -> withLowered a $ Output ll + MaybeBranch t a ll l -> withLowered a $ \a' -> MaybeBranch t a' ll l + Return a -> withLowered a $ Return + TailCall f c a -> withLowered f $ \f' -> TailCall f' c a + ErrorStmt msg -> withLowered msg $ ErrorStmt + VariantElim c a ls -> withLowered a $ \a' -> VariantElim c a' ls + -- No atoms are output/read + Jump {} -> return (mempty, blockTerm blk) + Br {} -> return (mempty, blockTerm blk) + + where + termPos = pos (blockTerm blk) + withLowered :: forall (tp :: CrucibleType) ty. + Atom s tp + -> (Atom s tp -> TermStmt s ty) -> m (Seq (Posd (Stmt ext s)), Posd (TermStmt s ty)) + withLowered a k = + do (setAtom, a') <- lowerAtomRead termPos a + return (setAtom, Posd termPos (k a')) + + lowerAtomRead :: forall (tp :: CrucibleType). Position -> Atom s tp -> m (Seq (Posd (Stmt ext s)), Atom s tp) + lowerAtomRead p a = + do (sub, setValue) <- lowerAtom ng pvals (Some a) + let a' = apSubst (atomSubst sub) a + return $ (Posd p <$> Seq.fromList setValue, a') + + +-- | Replace each write of a possibly-undef atom/register to a write of the +-- associated partial register by injecting it into a value of Maybe type. +lowerValueWrites :: forall m ext s. (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> Posd (Stmt ext s) + -> m (Seq (Posd (Stmt ext s))) +lowerValueWrites ng pvals st = + case pos_val st of + -- Replace r := a (morally) with pr := Just a, + -- where pr is the partial register associated with r + SetReg r a + | Just (getPartial -> pr) <- MapF.lookup (RegValue r) pvals -> + setMaybeAtom pr a (typeOfAtom a) + | otherwise -> orig + + -- Given a := v, append pr := Just(a) where pr is the + -- partial register associated with a + DefineAtom a _ + | Just (getPartial -> pr) <- MapF.lookup (AtomValue a) pvals -> + do setA' <- setMaybeAtom pr a (typeOfAtom a) + return (st Seq.<| setA') + | otherwise -> orig + + -- No registers set or atoms defined: + WriteGlobal {} -> orig + WriteRef {} -> orig + DropRef {} -> orig + Print {} -> orig + Assert {} -> orig + Assume {} -> orig + Breakpoint {} -> orig + + where + orig = pure (Seq.fromList [st]) + + -- Construct (pa := Just a; pr := pa) where pa is fresh + setMaybeAtom :: forall (tp :: CrucibleType). + Reg s (MaybeType tp) -> Atom s tp -> TypeRepr tp -> m (Seq (Posd (Stmt ext s))) + setMaybeAtom pr a ty = + do pa <- freshAtom ng (atomPosition a) (MaybeRepr ty) + let setPa = Posd (pos st) (DefineAtom pa (EvalApp (JustValue ty a))) + setPr = Posd (pos st) (SetReg pr pa) + return $ Seq.fromList [ setPa, setPr ] + +-- | Replace each read of a lowered atom/register to a read of the +-- associated register + projection from Maybe +lowerValueReads :: forall m ext s + . (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> Posd (Stmt ext s) + -> m (Seq (Posd (Stmt ext s))) +lowerValueReads ng pvals st = + case pos_val st of + -- RegReads have only one form + DefineAtom a (ReadReg r) + | Just (getPartial -> pr) <- MapF.lookup (RegValue r) pvals -> + lowerRegRead ng (pos st) a pr + -- For everything else, we need to check if any of the + -- referenced atoms need to be lowered + DefineAtom {} -> lowerAtomReads ng pvals atomsToLower st + SetReg {} -> lowerAtomReads ng pvals atomsToLower st + WriteGlobal {} -> lowerAtomReads ng pvals atomsToLower st + WriteRef {} -> lowerAtomReads ng pvals atomsToLower st + DropRef {} -> lowerAtomReads ng pvals atomsToLower st + Print {} -> lowerAtomReads ng pvals atomsToLower st + Assert {} -> lowerAtomReads ng pvals atomsToLower st + Assume {} -> lowerAtomReads ng pvals atomsToLower st + Breakpoint {} -> lowerAtomReads ng pvals atomsToLower st + where + atomsToLower :: [Some (Atom s)] + atomsToLower = Set.toList (foldStmtInputs addIfLowered (pos_val st) mempty) + + addIfLowered :: forall tp. Value s tp -> Set.Set (Some (Atom s)) -> Set.Set (Some (Atom s)) + addIfLowered v@(AtomValue a) s + | MapF.member v pvals = Set.insert (Some a) s + addIfLowered _ s = s + +-- | Replace each read of a lowered atom to a read of the +-- associated register + projection from Maybe +lowerAtomReads :: forall m ext s. + (Monad m, TraverseExt ext) + => NonceGenerator m s + -> ValueToPartialMap s + -> [Some (Atom s)] + -> Posd (Stmt ext s) + -> m (Seq (Posd (Stmt ext s))) +lowerAtomReads ng pvals atomsToLower st = + do (substs, readRegs) <- unzip <$> mapM (lowerAtom ng pvals) atomsToLower + let substMap = atomSubst (concat substs) + st' <- mapStmtAtom (return . apSubst substMap) (pos_val st) + let stmts = Seq.fromList (Posd (pos st) <$> (concat readRegs ++ [st'])) + return stmts + +apSubst :: AtomSubst s -> (forall (tp :: CrucibleType). Atom s tp -> Atom s tp) +apSubst sub n = fromMaybe n $ MapF.lookup n sub + +atomSubst :: [MapF.Pair (Atom s :: CrucibleType -> Type) (Atom s)] -> AtomSubst s +atomSubst substs = MapF.fromList substs + +-- | Given an atom @a@ of type @t@ whose definition we've already +-- replaced with a register @r@ of type @Maybe t@, produce the +-- statements to +-- 1. read @r@ into a fresh @a'@ +-- 2. set fresh @a''@ to @fromJust a'@ +-- returns a mapping from @a@ to @a'@ and the above +lowerAtom :: forall m s ext. + Monad m + => NonceGenerator m s + -> ValueToPartialMap s + -> Some (Atom s) + -> m ([AtomPair s], [Stmt ext s]) +lowerAtom ng pvals (Some a) + | Just (getPartial -> r) <- MapF.lookup (AtomValue a) pvals = + do a' <- substAtom (const (freshNonce ng)) a + str <- freshAtom ng (atomPosition a) knownRepr + a'' <- freshAtom ng (atomPosition a) (MaybeRepr (typeOfAtom a)) + let defs = [ DefineAtom a'' (ReadReg r) + , DefineAtom str (EvalApp (StringLit ("Lower Atom Pass: " <> fromString (show (atomId a))))) + , DefineAtom a' (EvalApp (FromJustValue (typeOfAtom a) a'' str)) + ] + return ([MapF.Pair a a'], defs) + | otherwise = + return ([], []) + +-- | @lowerRegRead ng pos a pr@ constructs @a' := pr; a := fromJust a'@. +lowerRegRead :: Monad m + => NonceGenerator m s + -> Position + -- ^ The position we should use for the new statements + -> Atom s tp + -- ^ The atom we're defininig + -> Reg s (MaybeType tp) + -- ^ The partial register to read from + -> m (Seq (Posd (Stmt ext s))) +lowerRegRead ng p a pr = + do a' <- freshAtom ng (atomPosition a) (MaybeRepr (typeOfAtom a)) + str <- freshAtom ng (atomPosition a) knownRepr + -- insert a new atom to read the reg, then replace with FromJustVal + let stmts = [ DefineAtom str (EvalApp (StringLit "Lower Register Pass")) + , DefineAtom a' (ReadReg pr) + , DefineAtom a (EvalApp (FromJustValue (typeOfAtom a) a' str)) + ] + return $ Seq.fromList (Posd p <$> stmts) + +-- | Traverse all dfs paths, avoiding backedges, to find values that may be read but not written. +-- Returns: +-- 1. a mapping from values of type @t@ to corresponding registers of type @Maybe t@ +-- 2. statements to initialize the registers mentioned in said mapping. +mkPartialRegMap :: (Monad m, TraverseExt ext) + => NonceGenerator m s + -> CFG ext s init ret + -> m ((ValueToPartialMap s, Seq (Posd (Stmt ext s)))) +mkPartialRegMap ng cfg = + traverseCFG gatherPvals (MapF.empty, mempty) (blockExtraInputs entry) entry cfg + where + entry = cfgEntryBlock cfg + + gatherPvals pvals env blk = + do refs' <- Fold.foldlM addPval pvals (blockUndefVals env blk) + return (refs', env <> blockAssignedValues blk) + + addPval (pvals, inits) val@(Some v) + | Just _ <- MapF.lookup v pvals + = return (pvals, inits) + | otherwise + = do (MapF.Pair vundef pval, is) <- makePartialReg ng val + return (MapF.insert vundef pval pvals, inits <> is) + +-- | Given a value @v@ of type @t@, create a new register @r@ of type +-- @Maybe t@. This function returns 1. the mapping from @v@ to such +-- an @r@, as well as the @stmts@ that will initialize @r@ to +-- @Nothing : Maybe t@. +makePartialReg :: Monad m + => NonceGenerator m s + -> Some (Value s) + -> m (MapF.Pair (Value s) (PartialValue s), Seq (Posd (Stmt ext s))) +makePartialReg ng (Some val) = + do a <- freshAtom ng p (MaybeRepr ty) + r <- freshReg ng p (MaybeRepr ty) + let v = EvalApp (NothingValue ty) + s = DefineAtom a v + sr = SetReg r a + inits = Posd p <$> [s, sr] + return (MapF.Pair val (PartialValue r), Seq.fromList inits) + where + (ty, p) = case val of + RegValue reg -> (typeOfReg reg, regPosition reg) + AtomValue atom -> (typeOfAtom atom, atomPosition atom) + +------------------- +-- | Merging Paths +------------------- + +-- | This is a record used to construct/manage the variant type that the router block +-- will use to switch on. The important piece is the map that relates blockIDs to an index +-- into the variant type's ctx -- with this map we can associate a _value_ of the variant type +-- with a given blockID +data BlockSwitchInfo s ctx = BlockSwitchInfo + { switchRepr :: CtxRepr ctx + , switchSize :: Ctx.Size ctx + , switchMap :: Map.Map (BlockID s) (Ctx.Index ctx UnitType) + } + deriving Show + +-- | Used as a substitution between labels. +-- Closes over the type of LambdaLabels +data BlockIDPair s where + Labels :: Label s -> Label s -> BlockIDPair s + LambdaLabels :: LambdaLabel s tp -> LambdaLabel s tp -> BlockIDPair s + +instance Show (BlockIDPair s) where + show (Labels l1 l2) = show l1 ++ " => " ++ show l2 + show (LambdaLabels l1 l2) = show l1 ++ " =>{lambda} " ++ show l2 + +-- | This is the main pass that attempts to optimize early exits in +-- the loops in a CFG. In particular, this transformation ensures that the +-- postdominator of the loop header is a member of the loop. +-- +-- Given a natural loop, its members are a set of blocks @bs@. Let the exit edges be +-- the edges from some block @b@ in @bs@ to either the loop header or a block not in @bs@. +-- +-- Let (i, j) be such an exit edge.This transofrmation inserts a new +-- block @r@ such that in the transformed cfg there is an edge (i, r) +-- and an edge (r, j). Moreover, the transformation ensures that [i, +-- r, j'] is not feasible for j' != j. This works by setting a +-- "destination" register @d := j@ in each block i for each exit edge +-- (i, j), and switching on the value of @d@ in the block @r@. +earlyMergeLoops :: ( TraverseExt ext, Monad m, Show (CFG ext s init ret) ) + => NonceGenerator m s + -> CFG ext s init ret + -> m (CFG ext s init ret) +earlyMergeLoops ng cfg0 = + do cfg' <- earlyMergeLoops' ng mempty (cfgLoops cfg0) cfg0 + lowerUndefPass ng (cfgEntryLabel cfg') cfg' + +-- Merge a loop from loops in cfg. The loops parameter is passed +-- to earlyMergeLoops (rather than calculated directly from cfg) +-- so that we can use see how the set of loops changes from +-- iteration to iteration: in particular, we want to make sure +-- that the number of loops does not increases +earlyMergeLoops' :: ( TraverseExt ext, Monad m, Show (CFG ext s init ret) ) + => NonceGenerator m s + -> Set (BlockID s) + -> [LoopInfo s] + -> CFG ext s init ret + -> m (CFG ext s init ret) +earlyMergeLoops' ng seen ls cfg + | Just l <- nextLoop + = do cfg' <- earlyMergeLoop ng cfg l + + -- Check if we should proceed: in particular, if the new CFG + -- renamed or produced new loops, then we need to bail as we + -- might not terminate in that case. + let ls' = cfgLoops cfg' + let seen' = (Set.insert (liHeader l) seen) + let nextStep = candidates seen' ls' + -- The termination transition invariant is that + when (length thisStep <= length nextStep) $ + panic "EarlyMergeLoops.earlyMergeLoops'" + ["Non-decreasing number of loops in earlyMegeLoops'"] + + earlyMergeLoops' ng seen' ls' cfg' + | otherwise + = return cfg + where + thisStep = + candidates seen ls + + nextLoop + | null thisStep = Nothing + | otherwise = Just (minimumBy isNested thisStep) + + candidates seenBlocks lis = + filter (unseen seenBlocks) lis + + + unseen s li = liHeader li `Set.notMember` s + +-- | Apply the transformation described in @earlyMergeLoops@ to a single loop. +earlyMergeLoop :: ( TraverseExt ext, Monad m ) + => NonceGenerator m s + -> CFG ext s init ret + -> LoopInfo s + -> m (CFG ext s init ret) +earlyMergeLoop ng cfg li + | not (null exits) = + do bmap' <- funnelPaths ng bmap exits + return cfg { cfgBlocks = Map.elems bmap' } + | otherwise = + return cfg + where + exits = filterErrors (liEarlyExits li ++ liFooterIn li) + filterErrors = filter (not . errorPath bmap) + bmap = blockMap cfg + +-- | Given a set of edges (i, j) in E, +-- Create a single block that merges all paths before +-- continuing on to the respective j's +-- +-- Create a unique block F and multiple blocks i' j' such +-- that i -> i' -> F -> j' -> j. +-- This function defines a register 'r : () + () + ... + ()' +-- Each 'j' corresponds to one of these tags, so each +-- i' sets r to indicate which 'j' to jump to, and F +-- switches on r. Each j' is a lambda block that jumps to the +-- original j. +-- +-- E.g. given i0 -> j0, i1 -> j0, i2 -> j1, +-- then i0' = r := inj(0, ()); jump F +-- i1' = r := inj(0, ()); jump F +-- i2' = r := inj(1, ()); jump F +-- F = switch r { 0: j0', 1: j1' } +-- j0' = jump j0 +-- j1' = jump j1 +funnelPaths :: (TraverseExt ext, Monad m) + => NonceGenerator m s + -> Map.Map (BlockID s) (Block ext s ret) + -> [(BlockID s, BlockID s)] + -> m (Map.Map (BlockID s) (Block ext s ret)) +funnelPaths ng bmap paths = + case mkBlockSwitchInfo outBlocks of + Some p -> + do (rename, newBlocks) <- routePaths ng p outBlocks + let renamedMap = Fold.foldl' (updateBlock rename) bmap (fst <$> paths) + newMap = Fold.foldl' addNewBlock renamedMap newBlocks + + return newMap + where + outBlocks = nub (snd <$> paths) + + sub renaming stmt = Fold.foldl' runRename stmt renaming + addNewBlock m b = Map.insert (blockID b) b m + updateBlock ren m bid = Map.update (doUpdate ren) bid m + doUpdate renaming blk = Just $ mkBlock (blockID blk) (blockExtraInputs blk) + (blockStmts blk) (sub renaming <$> blockTerm blk) + + -- Apply the label substitution in 'renaming' + -- to the term stmt in tgt (no-op on stmts without labels) + runRename tgt renaming = + case (tgt, renaming) of + (Jump t, Labels from to) + | t == from -> Jump to + | otherwise -> tgt + (Jump _, LambdaLabels {}) -> tgt + + (Br p t1 t2, Labels from to) + | t1 == from -> Br p to t2 + | t2 == from -> Br p t1 to + | otherwise -> tgt + (Br {}, LambdaLabels {}) -> tgt + + (Output ll a, LambdaLabels from to) + | Just Refl <- testEquality ll from -> Output to a + | otherwise -> tgt + (Output {}, Labels {}) -> tgt + + (VariantElim ctx a assgn, r@(LambdaLabels {})) -> + VariantElim ctx a (fmapFC (renameLabel r) assgn) + (VariantElim {}, Labels {}) -> tgt + + (MaybeBranch t a l1 l2, Labels from to) + | l2 == from -> MaybeBranch t a l1 to + | otherwise -> tgt + (MaybeBranch t a l1 l2, LambdaLabels from to) + | Just Refl <- testEquality l1 from -> + MaybeBranch t a to l2 + | otherwise -> tgt + + {- No labels to rename -} + (Return _, _) -> tgt + (TailCall {}, _) -> tgt + (ErrorStmt {}, _) -> tgt + + renameLabel (LambdaLabels from to) ll + | Just Refl <- testEquality from ll = to + renameLabel _ l = l + + +-- | Given a list of blocks, build a record of a variant type such that each injection +-- is associated with a single block. +mkBlockSwitchInfo :: [BlockID s] -> Some (BlockSwitchInfo s) +mkBlockSwitchInfo bs = + case bs of + [] -> + Some (BlockSwitchInfo Ctx.empty Ctx.zeroSize mempty) + (b:bs') -> + case mkBlockSwitchInfo bs' of + Some (BlockSwitchInfo ctxRepr sz indices) -> + Some $ BlockSwitchInfo { switchRepr = ctxRepr Ctx.:> UnitRepr + , switchSize = Ctx.incSize sz + , switchMap = Map.insert b (Ctx.nextIndex sz) (Map.map Ctx.skipIndex indices) + } + +-- | This function does most of the work for @funnelPaths@. +-- In particular, given a list of blocks @b0...bn@, +-- it constructs a single @r@, a list @b_in0...b_inn@, and a list +-- @b_out0...@b_outn@ such that @b_in_i@ jump to @r@, and @r@ +-- jumps to the corresponding @b_out_i@. +-- +-- The return value is a pair of +-- (1) A list of BlockIDPairs, which should be understood as a substitution +-- on labels. This is necessary since we are introducing *new* blocks to replace +-- *old* jump targets. This substitution is used to update the old jump targets +-- (2) A list of newly created blocks +routePaths :: forall m ext ctx s ret + . (TraverseExt ext, Monad m) + => NonceGenerator m s + -> BlockSwitchInfo s ctx + -- ^ the variant info should map each element of @outs@ to an index into `ctx` + -> [BlockID s] + -- ^ the blocks that we want to join & then fan out from + -> m ([BlockIDPair s], [Block ext s ret]) +routePaths ng (BlockSwitchInfo ctx sz idxMap) outs = + do -- 'bsi' has the information we need to associate each input block + -- with an a particular *index* into a list of outputs. This means + -- for each destination that we're routing to, + -- we can set a register `r` to some value `v` + -- and case split on `r` in a 'router block' to recover the intended destination + + -- this associates each such index with the new 'destination' + mapping <- mkMapping + + -- This is the block that switches on the destination block. + -- l is its label, r is the register that we'll case split on, + -- and 'router' is the actual block definition containing the switch + (l, r, router) <- routerBlock ng ctx mapping + + -- construct the blocks feeding into the router. for each output block, + -- set 'r' appropriately, by fetching the value from the index map in 'vi' + (rename, injBlocks) <- unzip <$> traverse (mkInjBlock r l) outs + + -- Finally make the destination blocks that continue to the original + -- targets + let outputBlocks = Map.foldrWithKey (mkLambdaBlock rename mapping) [] idxMap + + return (rename, router : outputBlocks ++ injBlocks) + where + bidToTerm :: BlockID s -> [BlockIDPair s] -> TermStmt s ret + bidToTerm origOut rename = + case (origOut, rename) of + (LabelID ll, _ ) -> Jump ll + (LambdaID ll, LambdaLabels l1 l2:_) + | Just Refl <- testEquality (lambdaId ll) (lambdaId l1) -> Output l1 (lambdaAtom l2) + (_, _:rest) -> bidToTerm origOut rest + _ -> + error "Output blocks mismatched in routePaths" + + mkMapping = Ctx.generateM sz $ \idx -> + do n <- freshNonce ng + a <- freshAtom ng internal (ctx Ctx.! idx) + return (LambdaLabel n a) + + mkInjBlock reg rlabel j = + do let idx = idxMap Map.! j + (rename, injBlock) <- routerEntryBlock ng ctx reg j idx rlabel + return (rename, injBlock) + + mkLambdaBlock rename mapping blkId blkIdx blks = + mkBlock (LambdaID (mapping Ctx.! blkIdx)) + mempty + mempty + (Posd internal (bidToTerm blkId rename)) : blks + +-- | Create a block that switches on a register. This does the work of +-- allocating the new label and discriminant register +routerBlock :: ( TraverseExt ext, Monad m ) + => NonceGenerator m s + -> CtxRepr routing + -> Ctx.Assignment (LambdaLabel s) routing + -> m (Label s, Reg s (VariantType routing), Block ext s ret) +routerBlock ng ctx mapping = + do l <- Label <$> freshNonce ng + destReg <- freshReg ng internal (VariantRepr ctx) + readDest <- freshAtom ng internal (VariantRepr ctx) + let elim = VariantElim ctx readDest mapping + readVar = Posd internal (DefineAtom readDest (ReadReg destReg)) + funnel = mkBlock (LabelID l) mempty (pure readVar) (Posd internal elim) + return (l, destReg, funnel) + +-- | This creates a block that to be substituted for @origID@. +-- This block will set the given register to the injection +-- given by @destIdx@, and then jump to a router block (described in @routePaths@) +-- that will `switch` on this register. +routerEntryBlock :: ( TraverseExt ext, Monad m ) + => NonceGenerator m s + -> CtxRepr routing + -> Reg s (VariantType routing) + -- ^ The register we will switch on + -> BlockID s + -- ^ The ID of the block we're substituting for + -> Ctx.Index routing UnitType + -- ^ Which injection in the variant type to use + -> Label s + -- ^ The label of the router block + -> m (BlockIDPair s, Block ext s ret) +routerEntryBlock ng ctx r origID destIdx routerLabel = + do aUnit <- freshAtom ng internal UnitRepr + aInj <- freshAtom ng internal (VariantRepr ctx) + + (l, rename) <- + case origID of + LabelID l1 -> + do l2 <- substLabel (\_ -> freshNonce ng) l1 + return (LabelID l2, Labels l1 l2) + LambdaID l1@(LambdaLabel _ a) -> + do l' <- freshNonce ng + a' <- freshNonce ng + -- knot-tying in the LambdaLabel type results in an infinite loop + let l2 = LambdaLabel l' a { atomId = a' } + return (LambdaID l2, LambdaLabels l1 l2) + + let defUnit = Posd internal (DefineAtom aUnit (EvalApp EmptyApp)) + defVar = Posd internal (DefineAtom aInj (EvalApp (InjectVariant ctx destIdx aUnit))) + setReg = Posd internal (SetReg r aInj) + stmts = Seq.fromList [defUnit, defVar, setReg] + blk = mkBlock l mempty stmts (Posd internal (Jump routerLabel)) + + return (rename, blk) + +errorPath :: Map.Map (BlockID s) (Block ext s ret) -> CFGEdge s -> Bool +errorPath bmap (_, bid) = + case Map.lookup bid bmap of + Just (blockTerm -> Posd _ (ErrorStmt _)) -> True + _ -> False + +-- | Generally useful helpers + +freshAtom :: Monad m => NonceGenerator m s -> Position -> TypeRepr tp -> m (Atom s tp) +freshAtom ng p tp = + do i <- freshNonce ng + return $ Atom { atomPosition = p + , atomId = i + , atomSource = Assigned + , typeOfAtom = tp + } + +freshReg :: Monad m => NonceGenerator m s -> Position -> TypeRepr tp -> m (Reg s tp) +freshReg ng p tp = + do i <- freshNonce ng + return $ Reg { regPosition = p + , regId = i + , typeOfReg = tp + } + +findBlock :: CFG ext s init ret -> Label s -> Maybe (Block ext s ret) +findBlock g l = + Fold.find (\b -> blockID b == LabelID l) (cfgBlocks g) + +blockUndefVals :: ValueSet s -> Block ext s ret -> ValueSet s +blockUndefVals def blk = blockKnownInputs blk Set.\\ def + +blockMap :: CFG ext s init ret -> Map.Map (BlockID s) (Block ext s ret) +blockMap cfg = Map.fromList [ (blockID b, b) | b <- cfgBlocks cfg ] + +internal :: Position +internal = InternalPos diff --git a/src/Lang/Crucible/CFG/Expr.hs b/src/Lang/Crucible/CFG/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Expr.hs @@ -0,0 +1,1576 @@ +{- | +Module : Lang.Crucible.CFG.Expr +Description : Expression syntax definitions +Copyright : (c) Galois, Inc 2014-2016 +License : BSD3 +Maintainer : Joe Hendrix + +Define the syntax of Crucible expressions. Expressions represent +side-effect free computations that result in terms. The same +expression language is used both for registerized CFGs ("Lang.Crucible.CFG.Reg") +and for the core SSA-form CFGs ("Lang.Crucible.CFG.Core"). + +Evaluation of expressions is defined in module "Lang.Crucible.Simulator.Evaluation". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- This option is here because, without it, GHC takes an extremely +-- long time (forever?) to compile this module with profiling enabled. +-- The SpecConstr optimization appears to be the culprit, and this +-- option disables it. Perhaps we only need to disable this +-- optimization on profiling builds? +{-# OPTIONS_GHC -fno-spec-constr #-} + +module Lang.Crucible.CFG.Expr + ( -- * App + App(..) + , mapApp + , foldApp + , traverseApp + , pattern BoolEq + , pattern IntEq + , pattern RealEq + , pattern BVEq + + , pattern BoolIte + , pattern IntIte + , pattern RealIte + , pattern BVIte + -- * Base terms + , BaseTerm(..) + , module Lang.Crucible.CFG.Extension + , RoundingMode(..) + + , testVector + , compareVector + ) where + +import Control.Monad.Identity +import Control.Monad.State.Strict +import qualified Data.BitVector.Sized as BV +import Data.Kind (Type) +import Data.Vector (Vector) +import Numeric.Natural +import Prettyprinter +import qualified Data.Vector as V +import qualified GHC.Float as F + +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.TH.GADT as U +import Data.Parameterized.TraversableFC + +import What4.Interface (RoundingMode(..),StringLiteral(..), stringLiteralInfo) +import What4.InterpretedFloatingPoint (X86_80Val(..)) + +import Lang.Crucible.CFG.Extension +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types +import Lang.Crucible.Utils.PrettyPrint +import qualified Lang.Crucible.Utils.Structural as U + +------------------------------------------------------------------------ +-- BaseTerm + +-- | Base terms represent the subset of expressions +-- of base types, packaged together with a run-time +-- representation of their type. +data BaseTerm (f :: CrucibleType -> Type) tp + = BaseTerm { baseTermType :: !(BaseTypeRepr tp) + , baseTermVal :: !(f (BaseToType tp)) + } + +instance TestEqualityFC BaseTerm where + testEqualityFC testF (BaseTerm _ x) (BaseTerm _ y) = do + Refl <- testF x y + return Refl +instance TestEquality f => TestEquality (BaseTerm f) where + testEquality = testEqualityFC testEquality + +instance OrdFC BaseTerm where + compareFC cmpF (BaseTerm _ x) (BaseTerm _ y) = do + case cmpF x y of + LTF -> LTF + GTF -> GTF + EQF -> EQF +instance OrdF f => OrdF (BaseTerm f) where + compareF = compareFC compareF + +instance FunctorFC BaseTerm where + fmapFC = fmapFCDefault + +instance FoldableFC BaseTerm where + foldMapFC = foldMapFCDefault + +instance TraversableFC BaseTerm where + traverseFC f (BaseTerm tp x) = BaseTerm tp <$> f x + +------------------------------------------------------------------------ +-- App + +-- | Equality on booleans +pattern BoolEq :: () => (tp ~ BoolType) => f BoolType -> f BoolType -> App ext f tp +pattern BoolEq x y = BaseIsEq BaseBoolRepr x y + +-- | Equality on integers +pattern IntEq :: () => (tp ~ BoolType) => f IntegerType -> f IntegerType -> App ext f tp +pattern IntEq x y = BaseIsEq BaseIntegerRepr x y + +-- | Equality on real numbers. +pattern RealEq :: () => (tp ~ BoolType) => f RealValType -> f RealValType -> App ext f tp +pattern RealEq x y = BaseIsEq BaseRealRepr x y + +-- | Equality on bitvectors +pattern BVEq :: () => (1 <= w, tp ~ BoolType) => NatRepr w -> f (BVType w) -> f (BVType w) -> App ext f tp +pattern BVEq w x y = BaseIsEq (BaseBVRepr w) x y + + +-- | Return first or second value depending on condition. +pattern BoolIte :: () => (tp ~ BoolType) => f BoolType -> f tp -> f tp -> App ext f tp +pattern BoolIte c x y = BaseIte BaseBoolRepr c x y + +-- | Return first or second value depending on condition. +pattern IntIte :: () => (tp ~ IntegerType) => f BoolType -> f tp -> f tp -> App ext f tp +pattern IntIte c x y = BaseIte BaseIntegerRepr c x y + +-- | Return first or second number depending on condition. +pattern RealIte :: () => (tp ~ RealValType) => f BoolType -> f tp -> f tp -> App ext f tp +pattern RealIte c x y = BaseIte BaseRealRepr c x y + +-- | Return first or second value depending on condition. +pattern BVIte :: () => (1 <= w, tp ~ BVType w) => f BoolType -> NatRepr w -> f tp -> f tp -> App ext f tp +pattern BVIte c w x y = BaseIte (BaseBVRepr w) c x y + +-- | The main Crucible expression datastructure, defined as a +-- multisorted algebra. Type @'App' ext f tp@ encodes the top-level +-- application of a Crucible expression. The parameter @ext@ is used +-- to indicate which syntax extension is being used via the +-- @ExprExtension@ type family. The type parameter @tp@ is a +-- type index that indicates the Crucible type of the values denoted +-- by the given expression form. Parameter @f@ is used everywhere a +-- recursive sub-expression would go. Uses of the 'App' type will +-- tie the knot through this parameter. +data App (ext :: Type) (f :: CrucibleType -> Type) (tp :: CrucibleType) where + + ---------------------------------------------------------------------- + -- Syntax Extension + + ExtensionApp :: !(ExprExtension ext f tp) -> App ext f tp + + ---------------------------------------------------------------------- + -- Polymorphic + + -- | Return true if two base types are equal. + BaseIsEq :: !(BaseTypeRepr tp) + -> !(f (BaseToType tp)) + -> !(f (BaseToType tp)) + -> App ext f BoolType + + -- | Select one or other + BaseIte :: !(BaseTypeRepr tp) + -> !(f BoolType) + -> !(f (BaseToType tp)) + -> !(f (BaseToType tp)) + -> App ext f (BaseToType tp) + + ---------------------------------------------------------------------- + -- () + + EmptyApp :: App ext f UnitType + + ---------------------------------------------------------------------- + -- Any + + -- Build an ANY type package. + PackAny :: !(TypeRepr tp) + -> !(f tp) + -> App ext f AnyType + + -- Attempt to open an ANY type. Return the contained + -- value if it has the given type; otherwise return Nothing. + UnpackAny :: !(TypeRepr tp) + -> !(f AnyType) + -> App ext f (MaybeType tp) + + --------------------------------------------------------------------- + -- Bool + + BoolLit :: !Bool -> App ext f BoolType + + Not :: !(f BoolType) + -> App ext f BoolType + + And :: !(f BoolType) + -> !(f BoolType) + -> App ext f BoolType + Or :: !(f BoolType) + -> !(f BoolType) + -> App ext f BoolType + + -- Exclusive or of Boolean values. + BoolXor :: !(f BoolType) + -> !(f BoolType) + -> App ext f BoolType + + ---------------------------------------------------------------------- + -- Nat + + -- @NatLit n@ returns the value n. + NatLit :: !Natural -> App ext f NatType + -- Equality for natural numbers + NatEq :: !(f NatType) -> !(f NatType) -> App ext f BoolType + -- If/Then/Else on natural numbers + NatIte :: !(f BoolType) -> !(f NatType) -> !(f NatType) -> App ext f NatType + -- Less than on natural numbers. + NatLt :: !(f NatType) -> !(f NatType) -> App ext f BoolType + -- Less than or equal on natural numbers. + NatLe :: !(f NatType) -> !(f NatType) -> App ext f BoolType + -- Add two natural numbers. + NatAdd :: !(f NatType) -> !(f NatType) -> App ext f NatType + -- @NatSub x y@ equals @x - y@. + -- The result is undefined if the @x@ is less than @y@. + NatSub :: !(f NatType) -> !(f NatType) -> App ext f NatType + -- Multiply two natural numbers. + NatMul :: !(f NatType) -> !(f NatType) -> App ext f NatType + -- Divide two natural numbers. Undefined if the divisor is 0. + NatDiv :: !(f NatType) -> !(f NatType) -> App ext f NatType + -- Modular reduction on natural numbers. Undefined if the modulus is 0. + NatMod :: !(f NatType) -> !(f NatType) -> App ext f NatType + + ---------------------------------------------------------------------- + -- Integer + + -- Create a singleton real array from a numeric literal. + IntLit :: !Integer -> App ext f IntegerType + -- Less-than test on integers + IntLt :: !(f IntegerType) -> !(f IntegerType) -> App ext f BoolType + -- Less-than-or-equal test on integers + IntLe :: !(f IntegerType) -> !(f IntegerType) -> App ext f BoolType + -- Negation of an integer value + IntNeg :: !(f IntegerType) -> App ext f IntegerType + -- Add two integers. + IntAdd :: !(f IntegerType) -> !(f IntegerType) -> App ext f IntegerType + -- Subtract one integer from another. + IntSub :: !(f IntegerType) -> !(f IntegerType) -> App ext f IntegerType + -- Multiply two integers. + IntMul :: !(f IntegerType) -> !(f IntegerType) -> App ext f IntegerType + -- Divide two integers. Undefined if the divisor is 0. + IntDiv :: !(f IntegerType) -> !(f IntegerType) -> App ext f IntegerType + -- Modular reduction on integers. Undefined if the modulus is 0. + IntMod :: !(f IntegerType) -> !(f IntegerType) -> App ext f IntegerType + -- Integer absolute value + IntAbs :: !(f IntegerType) -> App ext f IntegerType + + ---------------------------------------------------------------------- + -- RealVal + + -- A real constant + RationalLit :: !Rational -> App ext f RealValType + + RealLt :: !(f RealValType) -> !(f RealValType) -> App ext f BoolType + RealLe :: !(f RealValType) -> !(f RealValType) -> App ext f BoolType + -- Negate a real number + RealNeg :: !(f RealValType) -> App ext f RealValType + -- Add two natural numbers. + RealAdd :: !(f RealValType) -> !(f RealValType) -> App ext f RealValType + -- Subtract one number from another. + RealSub :: !(f RealValType) -> !(f RealValType) -> App ext f RealValType + -- Multiple two numbers. + RealMul :: !(f RealValType) -> !(f RealValType) -> App ext f RealValType + -- Divide two numbers. + RealDiv :: !(f RealValType) -> !(f RealValType) -> App ext f RealValType + -- Compute the "real modulus", which is @x - y * floor(x ./ y)@ when + -- @y@ is not zero and @x@ when @y@ is zero. + RealMod :: !(f RealValType) -> !(f RealValType) -> App ext f RealValType + + -- Return true if real value is integer. + RealIsInteger :: !(f RealValType) -> App ext f BoolType + + ---------------------------------------------------------------------- + -- Float + + -- | Generate an "undefined" float value. The semantics of this construct are + -- still under discussion, see crucible#366. + FloatUndef :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + + -- Floating point constants + FloatLit :: !Float -> App ext f (FloatType SingleFloat) + DoubleLit :: !Double -> App ext f (FloatType DoubleFloat) + X86_80Lit :: !X86_80Val -> App ext f (FloatType X86_80Float) + FloatNaN :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + FloatPInf :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + FloatNInf :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + FloatPZero :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + FloatNZero :: !(FloatInfoRepr fi) -> App ext f (FloatType fi) + + -- Arithmetic operations + FloatNeg + :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatAbs + :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatSqrt + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + + FloatAdd + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatSub + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatMul + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatDiv + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + -- Foating-point remainder of the two operands + FloatRem + :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatMin + :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatMax + :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + FloatFMA + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + + -- Comparison operations + FloatEq :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatFpEq :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatGt :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatGe :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatLt :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatLe :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatNe :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + FloatFpApart :: !(f (FloatType fi)) -> !(f (FloatType fi)) -> App ext f BoolType + + FloatIte + :: !(FloatInfoRepr fi) + -> !(f BoolType) + -> !(f (FloatType fi)) + -> !(f (FloatType fi)) + -> App ext f (FloatType fi) + + -- Conversion operations + FloatCast + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (FloatType fi')) + -> App ext f (FloatType fi) + FloatFromBinary + :: !(FloatInfoRepr fi) + -> !(f (BVType (FloatInfoToBitWidth fi))) + -> App ext f (FloatType fi) + FloatToBinary + :: (1 <= FloatInfoToBitWidth fi) + => !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> App ext f (BVType (FloatInfoToBitWidth fi)) + FloatFromBV + :: (1 <= w) + => !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (BVType w)) + -> App ext f (FloatType fi) + FloatFromSBV + :: (1 <= w) + => !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f (BVType w)) + -> App ext f (FloatType fi) + FloatFromReal + :: !(FloatInfoRepr fi) + -> !RoundingMode + -> !(f RealValType) + -> App ext f (FloatType fi) + FloatToBV + :: (1 <= w) + => !(NatRepr w) + -> !RoundingMode + -> !(f (FloatType fi)) + -> App ext f (BVType w) + FloatToSBV + :: (1 <= w) + => !(NatRepr w) + -> !RoundingMode + -> !(f (FloatType fi)) + -> App ext f (BVType w) + FloatToReal :: !(f (FloatType fi)) -> App ext f RealValType + + -- Classification operations + FloatIsNaN :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsInfinite :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsZero :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsPositive :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsNegative :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsSubnormal :: !(f (FloatType fi)) -> App ext f BoolType + FloatIsNormal :: !(f (FloatType fi)) -> App ext f BoolType + + ---------------------------------------------------------------------- + -- Maybe + + JustValue :: !(TypeRepr tp) + -> !(f tp) + -> App ext f (MaybeType tp) + + NothingValue :: !(TypeRepr tp) -> App ext f (MaybeType tp) + + -- This is a partial operation with given a maybe value returns the + -- value if is defined and otherwise fails with the given error message. + -- + -- This operation should be used instead of pattern matching on a maybe + -- when you do not want an explicit error message being printed, but rather + -- want to assert that the value is defined. + FromJustValue :: !(TypeRepr tp) + -> !(f (MaybeType tp)) + -> !(f (StringType Unicode)) + -> App ext f tp + + ---------------------------------------------------------------------- + -- Recursive Types + RollRecursive :: IsRecursiveType nm + => !(SymbolRepr nm) + -> !(CtxRepr ctx) + -> !(f (UnrollType nm ctx)) + -> App ext f (RecursiveType nm ctx) + + UnrollRecursive + :: IsRecursiveType nm + => !(SymbolRepr nm) + -> !(CtxRepr ctx) + -> !(f (RecursiveType nm ctx)) + -> App ext f (UnrollType nm ctx) + + ---------------------------------------------------------------------- + -- Sequences + + -- Create an empty sequence + SequenceNil :: !(TypeRepr tp) -> App ext f (SequenceType tp) + + -- Add a new value to the front of a sequence + SequenceCons :: !(TypeRepr tp) + -> !(f tp) + -> !(f (SequenceType tp)) + -> App ext f (SequenceType tp) + + -- Append two sequences + SequenceAppend :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> !(f (SequenceType tp)) + -> App ext f (SequenceType tp) + + -- Test if a sequence is nil + SequenceIsNil :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> App ext f BoolType + + -- Return the length of a sequence + SequenceLength :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> App ext f NatType + + -- Return the head of a sesquence, if it is non-nil. + SequenceHead :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> App ext f (MaybeType tp) + + -- Return the tail of a sequence, if it is non-nil. + SequenceTail :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> App ext f (MaybeType (SequenceType tp)) + + -- Deconstruct a sequence. Return nothing if nil, + -- return the head and tail if non-nil. + SequenceUncons :: !(TypeRepr tp) + -> !(f (SequenceType tp)) + -> App ext f (MaybeType (StructType (EmptyCtx ::> tp ::> SequenceType tp))) + + ---------------------------------------------------------------------- + -- Vector + + -- Vector literal. + VectorLit :: !(TypeRepr tp) -> !(Vector (f tp)) -> App ext f (VectorType tp) + + -- Create an vector of constants. + VectorReplicate :: !(TypeRepr tp) + -> !(f NatType) + -> !(f tp) + -> App ext f (VectorType tp) + + -- Return true if vector is empty. + VectorIsEmpty :: !(f (VectorType tp)) + -> App ext f BoolType + + -- Size of vector + VectorSize :: !(f (VectorType tp)) -> App ext f NatType + + -- Return value stored in given entry. + VectorGetEntry :: !(TypeRepr tp) + -> !(f (VectorType tp)) + -> !(f NatType) + -> App ext f tp + + -- Update vector at given entry. + VectorSetEntry :: !(TypeRepr tp) + -> !(f (VectorType tp)) + -> !(f NatType) + -> !(f tp) + -> App ext f (VectorType tp) + + -- Cons an element onto the front of the vector + VectorCons :: !(TypeRepr tp) + -> !(f tp) + -> !(f (VectorType tp)) + -> App ext f (VectorType tp) + + ---------------------------------------------------------------------- + -- Handle + + HandleLit :: !(FnHandle args ret) + -> App ext f (FunctionHandleType args ret) + + -- Create a closure that captures the last argument. + Closure :: !(CtxRepr args) + -> !(TypeRepr ret) + -> !(f (FunctionHandleType (args::>tp) ret)) + -> !(TypeRepr tp) + -> !(f tp) + -> App ext f (FunctionHandleType args ret) + + ---------------------------------------------------------------------- + -- Conversions + + -- @NatToInteger@ convert a natural number to an integer. + NatToInteger :: !(f NatType) -> App ext f IntegerType + + -- @IntegerToReal@ convert an integer to a real. + IntegerToReal :: !(f IntegerType) -> App ext f RealValType + + -- @RealRound@ rounds the real number value toward the nearest integer. + -- Ties are rounded away from 0. + RealRound :: !(f RealValType) -> App ext f IntegerType + + -- @RealRound@ computes the largest integer less-or-equal to the given real number. + RealFloor :: !(f RealValType) -> App ext f IntegerType + + -- @RealCeil@ computes the smallest integer greater-or-equal to the given real number. + RealCeil :: !(f RealValType) -> App ext f IntegerType + + -- @IntegerToBV@ converts an integer value to a bitvector. This operations computes + -- the unique bitvector whose value is congruent to the input value modulo @2^w@. + IntegerToBV :: (1 <= w) => NatRepr w -> !(f IntegerType) -> App ext f (BVType w) + + -- @RealToNat@ convert a non-negative real integer to natural number. + -- This is partial, and requires that the input be a non-negative real + -- integer. + RealToNat :: !(f RealValType) -> App ext f NatType + + ---------------------------------------------------------------------- + -- ComplexReal + + -- Create complex number from two real numbers. + Complex :: !(f RealValType) -> !(f RealValType) -> App ext f ComplexRealType + RealPart :: !(f ComplexRealType) -> App ext f RealValType + ImagPart :: !(f ComplexRealType) -> App ext f RealValType + + ---------------------------------------------------------------------- + -- BV + + -- | Generate an "undefined" bitvector value. The semantics of this construct + -- are still under discussion, see crucible#366. + BVUndef :: (1 <= w) => NatRepr w -> App ext f (BVType w) + + BVLit :: (1 <= w) => NatRepr w -> BV.BV w -> App ext f (BVType w) + + -- concatenate two bitvectors + BVConcat :: (1 <= u, 1 <= v, 1 <= u+v) + => !(NatRepr u) + -> !(NatRepr v) + -> !(f (BVType u)) -- Most significant bits + -> !(f (BVType v)) -- Least significant bits + -> App ext f (BVType (u+v)) + + -- BVSelect idx n bv chooses bits [idx, .. , idx+n-1] from bitvector bv. + -- The resulting bitvector will have width n. + -- Index 0 denotes the least-significant bit. + BVSelect :: (1 <= w, 1 <= len, idx + len <= w) + => !(NatRepr idx) + -> !(NatRepr len) + -> !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType len) + + BVTrunc :: (1 <= r, r+1 <= w) + => !(NatRepr r) + -> !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType r) + + BVZext :: (1 <= w, 1 <= r, w+1 <= r) + => !(NatRepr r) + -> !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType r) + + BVSext :: (1 <= w, 1 <= r, w+1 <= r) + => !(NatRepr r) + -> !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType r) + + -- Complement bits in bitvector. + BVNot :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVAnd :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVOr :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVXor :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVNeg :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVAdd :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVSub :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVMul :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVUdiv :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + -- | This performs signed division. The result is truncated to zero. + -- + -- TODO: Document semantics when divisor is zero and case of + -- minSigned w / -1 = minSigned w. + BVSdiv :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVUrem :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVSrem :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f (BVType w) + + BVUle :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + BVUlt :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + BVSle :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + BVSlt :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + -- True if the unsigned addition of the two given bitvectors + -- has a carry-out; that is, if the unsigned addition overflows. + BVCarry :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + -- True if the signed addition of the two given bitvectors + -- has a signed overflow condition. + BVSCarry :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + -- True if the signed subtraction of the two given bitvectors + -- has a signed overflow condition. + BVSBorrow :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> !(f (BVType w)) + -> App ext f BoolType + + -- Perform a left-shift + BVShl :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) -- Value to shift + -> !(f (BVType w)) -- The shift amount as an unsigned integer. + -> App ext f (BVType w) + + -- Perform a logical shift right + BVLshr :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) -- Value to shift + -> !(f (BVType w)) -- The shift amount as an unsigned integer. + -> App ext f (BVType w) + + -- Perform a signed shift right (if the + BVAshr :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) -- Value to shift + -> !(f (BVType w)) -- The shift amount as an unsigned integer. + -> App ext f (BVType w) + + -- Rotate left + BVRol :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) -- Value to rotate + -> !(f (BVType w)) -- The rotate amount as an unsigned integer + -> App ext f (BVType w) + + -- Rotate right + BVRor :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) -- Value to rotate + -> !(f (BVType w)) -- The rotate amount as an unsigned integer + -> App ext f (BVType w) + + -- Return the number of consecutive 0 bits in the input, starting from + -- the most significant bit position. If the input is zero, all bits are counted + -- as leading. + BVCountLeadingZeros :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType w) + + -- Return the number of consecutive 0 bits in the input, starting from + -- the least significant bit position. If the input is zero, all bits are counted + -- as trailing. + BVCountTrailingZeros :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType w) + + -- popcount + BVPopcount :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f (BVType w) + + -- Return the minimum of the two arguments using unsigned comparisons + BVUMin :: + (1 <= w) => + !(NatRepr w) -> + !(f (BVType w)) -> + !(f (BVType w)) -> + App ext f (BVType w) + + -- Return the maximum of the two arguments using unsigned comparisons + BVUMax :: + (1 <= w) => + !(NatRepr w) -> + !(f (BVType w)) -> + !(f (BVType w)) -> + App ext f (BVType w) + + -- Return the minimum of the two arguments using signed comparisons + BVSMin :: + (1 <= w) => + !(NatRepr w) -> + !(f (BVType w)) -> + !(f (BVType w)) -> + App ext f (BVType w) + + -- Return the maximum of the two arguments using signed comparisons + BVSMax :: + (1 <= w) => + !(NatRepr w) -> + !(f (BVType w)) -> + !(f (BVType w)) -> + App ext f (BVType w) + + -- Given a Boolean, returns one if Boolean is True and zero otherwise. + BoolToBV :: (1 <= w) + => !(NatRepr w) + -> !(f BoolType) + -> App ext f (BVType w) + + -- Return the unsigned value of the given bitvector as an integer + BvToInteger :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f IntegerType + + -- Return the signed value of the given bitvector as an integer + SbvToInteger :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f IntegerType + + -- Return the unsigned value of the given bitvector as a nat + BvToNat :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f NatType + + BVNonzero :: (1 <= w) + => !(NatRepr w) + -> !(f (BVType w)) + -> App ext f BoolType + + ---------------------------------------------------------------------- + -- WordMap + + EmptyWordMap :: (1 <= w) + => !(NatRepr w) + -> !(BaseTypeRepr tp) + -> App ext f (WordMapType w tp) + + InsertWordMap :: (1 <= w) + => !(NatRepr w) + -> !(BaseTypeRepr tp) + -> !(f (BVType w)) + -> !(f (BaseToType tp)) + -> !(f (WordMapType w tp)) + -> App ext f (WordMapType w tp) + + LookupWordMap :: (1 <= w) + => !(BaseTypeRepr tp) + -> !(f (BVType w)) + -> !(f (WordMapType w tp)) + -> App ext f (BaseToType tp) + + LookupWordMapWithDefault + :: (1 <= w) + => !(BaseTypeRepr tp) + -> !(f (BVType w)) + -> !(f (WordMapType w tp)) + -> !(f (BaseToType tp)) + -> App ext f (BaseToType tp) + + ---------------------------------------------------------------------- + -- Variants + + InjectVariant :: !(CtxRepr ctx) + -> !(Ctx.Index ctx tp) + -> !(f tp) + -> App ext f (VariantType ctx) + + ProjectVariant :: !(CtxRepr ctx) + -> !(Ctx.Index ctx tp) + -> !(f (VariantType ctx)) + -> App ext f (MaybeType tp) + + ---------------------------------------------------------------------- + -- Struct + + MkStruct :: !(CtxRepr ctx) + -> !(Ctx.Assignment f ctx) + -> App ext f (StructType ctx) + + GetStruct :: !(f (StructType ctx)) + -> !(Ctx.Index ctx tp) + -> !(TypeRepr tp) + -> App ext f tp + + SetStruct :: !(CtxRepr ctx) + -> !(f (StructType ctx)) + -> !(Ctx.Index ctx tp) + -> !(f tp) + -> App ext f (StructType ctx) + + ---------------------------------------------------------------------- + -- StringMapType + + -- Initialize the ident value map to the given value. + EmptyStringMap :: !(TypeRepr tp) + -> App ext f (StringMapType tp) + + -- Lookup the value of a string in a string map. + LookupStringMapEntry :: !(TypeRepr tp) + -> !(f (StringMapType tp)) + -> !(f (StringType Unicode)) + -> App ext f (MaybeType tp) + + -- Update the name of the ident value map with the given value. + InsertStringMapEntry :: !(TypeRepr tp) + -> !(f (StringMapType tp)) + -> !(f (StringType Unicode)) + -> !(f (MaybeType tp)) + -> App ext f (StringMapType tp) + + ---------------------------------------------------------------------- + -- String + + -- Create a concrete string literal + StringLit :: !(StringLiteral si) + -> App ext f (StringType si) + + -- Create an empty string literal + StringEmpty :: !(StringInfoRepr si) + -> App ext f (StringType si) + + StringConcat :: !(StringInfoRepr si) + -> !(f (StringType si)) + -> !(f (StringType si)) + -> App ext f (StringType si) + + -- Compute the length of a string + StringLength :: !(f (StringType si)) + -> App ext f IntegerType + + -- Test if the first string contains the second string as a substring + StringContains :: !(f (StringType si)) + -> !(f (StringType si)) + -> App ext f BoolType + + -- Test if the first string is a prefix of the second string + StringIsPrefixOf :: !(f (StringType si)) + -> !(f (StringType si)) + -> App ext f BoolType + + -- Test if the first string is a suffix of the second string + StringIsSuffixOf :: !(f (StringType si)) + -> !(f (StringType si)) + -> App ext f BoolType + + -- Return the first position at which the second string can be found as a substring + -- in the first string, starting from the given index. + -- If no such position exists, or if the index is out of range, return a negative value. + StringIndexOf :: !(f (StringType si)) + -> !(f (StringType si)) + -> !(f IntegerType) + -> App ext f IntegerType + + -- @stringSubstring s off len@ extracts the substring of @s@ starting at index @off@ and + -- having length no more than @len@. This operation returns the empty string if + -- @len@ is negative or if @off@ is not in range. + StringSubstring :: !(StringInfoRepr si) + -> !(f (StringType si)) + -> !(f IntegerType) + -> !(f IntegerType) + -> App ext f (StringType si) + + ShowValue :: !(BaseTypeRepr bt) + -> !(f (BaseToType bt)) + -> App ext f (StringType Unicode) + + ShowFloat :: !(FloatInfoRepr fi) + -> !(f (FloatType fi)) + -> App ext f (StringType Unicode) + + ---------------------------------------------------------------------- + -- Arrays (supporting symbolic operations) + + SymArrayLookup :: !(BaseTypeRepr b) + -> !(f (SymbolicArrayType (idx ::> tp) b)) + -> !(Ctx.Assignment (BaseTerm f) (idx ::> tp)) + -> App ext f (BaseToType b) + + SymArrayUpdate :: !(BaseTypeRepr b) + -> !(f (SymbolicArrayType (idx ::> itp) b)) + -> !(Ctx.Assignment (BaseTerm f) (idx ::> itp)) + -> !(f (BaseToType b)) + -> App ext f (SymbolicArrayType (idx ::> itp) b) + + ------------------------------------------------------------------------ + -- Introspection + + -- Returns true if the given value is a concrete value, false otherwise. + -- This is primarily intended to assist with issuing warnings and such + -- when a value is expected to be concrete. This primitive could be + -- used for evil; try to avoid the temptation. + IsConcrete :: !(BaseTypeRepr b) + -> f (BaseToType b) + -> App ext f BoolType + + ------------------------------------------------------------------------ + -- References + + -- Check whether two references are equal. + ReferenceEq :: !(TypeRepr tp) + -> !(f (ReferenceType tp)) + -> !(f (ReferenceType tp)) + -> App ext f BoolType + + +-- | Compute a run-time representation of the type of an application. +instance TypeApp (ExprExtension ext) => TypeApp (App ext) where + -- appType :: App ext f tp -> TypeRepr tp + appType a0 = + case a0 of + BaseIsEq{} -> knownRepr + BaseIte tp _ _ _ -> baseToType tp + --------------------------------------------------------------------- + -- Extension + ExtensionApp x -> appType x + + ---------------------------------------------------------------------- + -- () + EmptyApp -> knownRepr + ---------------------------------------------------------------------- + -- Any + PackAny{} -> knownRepr + UnpackAny tp _ -> MaybeRepr tp + ---------------------------------------------------------------------- + -- Bool + BoolLit{} -> knownRepr + Not{} -> knownRepr + And{} -> knownRepr + Or{} -> knownRepr + BoolXor{} -> knownRepr + ---------------------------------------------------------------------- + -- Nat + NatLit{} -> knownRepr + NatEq{} -> knownRepr + NatIte{} -> knownRepr + NatLt{} -> knownRepr + NatLe{} -> knownRepr + NatAdd{} -> knownRepr + NatSub{} -> knownRepr + NatMul{} -> knownRepr + NatDiv{} -> knownRepr + NatMod{} -> knownRepr + + ---------------------------------------------------------------------- + -- Integer + IntLit{} -> knownRepr + IntLt{} -> knownRepr + IntLe{} -> knownRepr + IntNeg{} -> knownRepr + IntAdd{} -> knownRepr + IntSub{} -> knownRepr + IntMul{} -> knownRepr + IntDiv{} -> knownRepr + IntMod{} -> knownRepr + IntAbs{} -> knownRepr + + ---------------------------------------------------------------------- + -- RealVal + RationalLit{} -> knownRepr + RealAdd{} -> knownRepr + RealSub{} -> knownRepr + RealMul{} -> knownRepr + RealDiv{} -> knownRepr + RealMod{} -> knownRepr + RealNeg{} -> knownRepr + RealLe{} -> knownRepr + RealLt{} -> knownRepr + RealIsInteger{} -> knownRepr + + ---------------------------------------------------------------------- + -- Float + FloatUndef fi -> FloatRepr fi + FloatLit{} -> knownRepr + DoubleLit{} -> knownRepr + X86_80Lit{} -> knownRepr + FloatNaN fi -> FloatRepr fi + FloatPInf fi -> FloatRepr fi + FloatNInf fi -> FloatRepr fi + FloatPZero fi -> FloatRepr fi + FloatNZero fi -> FloatRepr fi + FloatNeg fi _ -> FloatRepr fi + FloatAbs fi _ -> FloatRepr fi + FloatSqrt fi _ _ -> FloatRepr fi + FloatAdd fi _ _ _ -> FloatRepr fi + FloatSub fi _ _ _ -> FloatRepr fi + FloatMul fi _ _ _ -> FloatRepr fi + FloatDiv fi _ _ _ -> FloatRepr fi + FloatRem fi _ _ -> FloatRepr fi + FloatMin fi _ _ -> FloatRepr fi + FloatMax fi _ _ -> FloatRepr fi + FloatFMA fi _ _ _ _ -> FloatRepr fi + FloatEq{} -> knownRepr + FloatFpEq{} -> knownRepr + FloatLt{} -> knownRepr + FloatLe{} -> knownRepr + FloatGt{} -> knownRepr + FloatGe{} -> knownRepr + FloatNe{} -> knownRepr + FloatFpApart{} -> knownRepr + FloatIte fi _ _ _ -> FloatRepr fi + FloatCast fi _ _ -> FloatRepr fi + FloatFromBinary fi _ -> FloatRepr fi + FloatToBinary fi _ -> case floatInfoToBVTypeRepr fi of + BaseBVRepr w -> BVRepr w + FloatFromBV fi _ _ -> FloatRepr fi + FloatFromSBV fi _ _ -> FloatRepr fi + FloatFromReal fi _ _ -> FloatRepr fi + FloatToBV w _ _ -> BVRepr w + FloatToSBV w _ _ -> BVRepr w + FloatToReal{} -> knownRepr + FloatIsNaN{} -> knownRepr + FloatIsInfinite{} -> knownRepr + FloatIsZero{} -> knownRepr + FloatIsPositive{} -> knownRepr + FloatIsNegative{} -> knownRepr + FloatIsSubnormal{} -> knownRepr + FloatIsNormal{} -> knownRepr + + ---------------------------------------------------------------------- + -- Maybe + + JustValue tp _ -> MaybeRepr tp + NothingValue tp -> MaybeRepr tp + FromJustValue tp _ _ -> tp + + ---------------------------------------------------------------------- + -- Recursive Types + + RollRecursive nm ctx _ -> RecursiveRepr nm ctx + UnrollRecursive nm ctx _ -> unrollType nm ctx + + ---------------------------------------------------------------------- + -- Vector + VectorIsEmpty{} -> knownRepr + VectorSize{} -> knownRepr + VectorLit tp _ -> VectorRepr tp + VectorReplicate tp _ _ -> VectorRepr tp + VectorGetEntry tp _ _ -> tp + VectorSetEntry tp _ _ _ -> VectorRepr tp + VectorCons tp _ _ -> VectorRepr tp + + ---------------------------------------------------------------------- + -- Sequence + SequenceNil tpr -> SequenceRepr tpr + SequenceCons tpr _ _ -> SequenceRepr tpr + SequenceAppend tpr _ _ -> SequenceRepr tpr + SequenceIsNil _ _ -> knownRepr + SequenceHead tpr _ -> MaybeRepr tpr + SequenceUncons tpr _ -> + MaybeRepr (StructRepr (Ctx.Empty Ctx.:> tpr Ctx.:> SequenceRepr tpr)) + SequenceLength{} -> knownRepr + SequenceTail tpr _ -> MaybeRepr (SequenceRepr tpr) + + ---------------------------------------------------------------------- + -- SymbolicArrayType + + SymArrayLookup b _ _ -> baseToType b + SymArrayUpdate b _ idx _ -> + baseToType (BaseArrayRepr (fmapFC baseTermType idx) b) + + ---------------------------------------------------------------------- + -- WordMap + EmptyWordMap w tp -> WordMapRepr w tp + InsertWordMap w tp _ _ _ -> WordMapRepr w tp + LookupWordMap tp _ _ -> baseToType tp + LookupWordMapWithDefault tp _ _ _ -> baseToType tp + + ---------------------------------------------------------------------- + -- Handle + + HandleLit h -> handleType h + Closure a r _ _ _ -> + FunctionHandleRepr a r + + ---------------------------------------------------------------------- + -- Conversions + NatToInteger{} -> knownRepr + IntegerToReal{} -> knownRepr + RealToNat{} -> knownRepr + RealRound{} -> knownRepr + RealFloor{} -> knownRepr + RealCeil{} -> knownRepr + IntegerToBV w _ -> BVRepr w + + ---------------------------------------------------------------------- + -- ComplexReal + Complex{} -> knownRepr + RealPart{} -> knownRepr + ImagPart{} -> knownRepr + + ---------------------------------------------------------------------- + -- BV + BVUndef w -> BVRepr w + BVLit w _ -> BVRepr w + BVTrunc w _ _ -> BVRepr w + BVZext w _ _ -> BVRepr w + BVSext w _ _ -> BVRepr w + + BVNot w _ -> BVRepr w + BVAnd w _ _ -> BVRepr w + BVOr w _ _ -> BVRepr w + BVXor w _ _ -> BVRepr w + BVNeg w _ -> BVRepr w + BVAdd w _ _ -> BVRepr w + BVSub w _ _ -> BVRepr w + BVMul w _ _ -> BVRepr w + BVUdiv w _ _ -> BVRepr w + BVSdiv w _ _ -> BVRepr w + BVUrem w _ _ -> BVRepr w + BVSrem w _ _ -> BVRepr w + BVUle{} -> knownRepr + BVUlt{} -> knownRepr + BVSle{} -> knownRepr + BVSlt{} -> knownRepr + BVCarry{} -> knownRepr + BVSCarry{} -> knownRepr + BVSBorrow{} -> knownRepr + BVShl w _ _ -> BVRepr w + BVLshr w _ _ -> BVRepr w + BVAshr w _ _ -> BVRepr w + BVRol w _ _ -> BVRepr w + BVRor w _ _ -> BVRepr w + BVCountTrailingZeros w _ -> BVRepr w + BVCountLeadingZeros w _ -> BVRepr w + BVPopcount w _ -> BVRepr w + BVUMax w _ _ -> BVRepr w + BVUMin w _ _ -> BVRepr w + BVSMax w _ _ -> BVRepr w + BVSMin w _ _ -> BVRepr w + + BoolToBV w _ -> BVRepr w + BvToNat{} -> knownRepr + BvToInteger{} -> knownRepr + SbvToInteger{} -> knownRepr + BVNonzero{} -> knownRepr + BVSelect _ n _ _ -> BVRepr n + BVConcat w1 w2 _ _ -> BVRepr (addNat w1 w2) + + ---------------------------------------------------------------------- + -- Struct + + MkStruct ctx _ -> StructRepr ctx + GetStruct _ _ tp -> tp + SetStruct ctx _ _ _ -> StructRepr ctx + + ---------------------------------------------------------------------- + -- Variants + + InjectVariant ctx _ _ -> VariantRepr ctx + ProjectVariant ctx idx _ -> MaybeRepr (ctx Ctx.! idx) + + ---------------------------------------------------------------------- + -- StringMap + EmptyStringMap tp -> StringMapRepr tp + LookupStringMapEntry tp _ _ -> MaybeRepr tp + InsertStringMapEntry tp _ _ _ -> StringMapRepr tp + + ---------------------------------------------------------------------- + -- String + + StringLit s -> StringRepr (stringLiteralInfo s) + ShowValue{} -> knownRepr + ShowFloat{} -> knownRepr + StringConcat si _ _ -> StringRepr si + StringEmpty si -> StringRepr si + StringLength _ -> knownRepr + StringContains{} -> knownRepr + StringIsPrefixOf{} -> knownRepr + StringIsSuffixOf{} -> knownRepr + StringIndexOf{} -> knownRepr + StringSubstring si _ _ _ -> StringRepr si + + ------------------------------------------------------------------------ + -- Introspection + + IsConcrete _ _ -> knownRepr + + ------------------------------------------------------------------------ + -- References + + ReferenceEq{} -> knownRepr + + +---------------------------------------------------------------------------- +-- Utility operations + +testFnHandle :: FnHandle a1 r1 -> FnHandle a2 r2 -> Maybe (FnHandle a1 r1 :~: FnHandle a2 r2) +testFnHandle x y = do + Refl <- testEquality (handleID x) (handleID y) + return Refl + +compareFnHandle :: FnHandle a1 r1 + -> FnHandle a2 r2 + -> OrderingF (FnHandle a1 r1) (FnHandle a2 r2) +compareFnHandle x y = do + case compareF (handleID x) (handleID y) of + LTF -> LTF + GTF -> GTF + EQF -> EQF + +testVector :: (forall x y. f x -> f y -> Maybe (x :~: y)) + -> Vector (f tp) -> Vector (f tp) -> Maybe (Int :~: Int) +testVector testF x y = do + case V.zipWithM_ testF x y of + Just () -> Just Refl + Nothing -> Nothing + +compareVector :: forall f tp. (forall x y. f x -> f y -> OrderingF x y) + + -> Vector (f tp) -> Vector (f tp) -> OrderingF Int Int +compareVector cmpF x y + | V.length x < V.length y = LTF + | V.length x > V.length y = GTF + | otherwise = V.foldr go EQF (V.zip x y) + where go :: forall z. (f z, f z) -> OrderingF Int Int -> OrderingF Int Int + go (u,v) r = + case cmpF u v of + LTF -> LTF + GTF -> GTF + EQF -> r + +-- Force app to be in context. +$(return []) + +------------------------------------------------------------------------ +-- Pretty printing + +ppBaseTermAssignment :: (forall u . f u -> Doc ann) + -> Ctx.Assignment (BaseTerm f) ctx + -> Doc ann +ppBaseTermAssignment pp v = brackets (commas (toListFC (pp . baseTermVal) v)) + +instance PrettyApp (ExprExtension ext) => PrettyApp (App ext) where + --ppApp :: (forall a . f a -> Doc ann) -> App ext f b -> Doc ann + ppApp = $(U.structuralPretty [t|App|] + [ ( U.ConType [t|Ctx.Assignment|] + `U.TypeApp` (U.ConType [t|BaseTerm|] `U.TypeApp` U.DataArg 1) + `U.TypeApp` U.AnyType + , [| ppBaseTermAssignment |] + ) + , (U.ConType [t|ExprExtension|] `U.TypeApp` + U.DataArg 0 `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType, + [| ppApp |] + ) + , ( U.ConType [t|Vector|] `U.TypeApp` U.AnyType + , [| \pp v -> brackets (commas (fmap pp v)) |] + ) + ]) + +------------------------------------------------------------------------ +-- TraverseApp (requires TemplateHaskell) + +traverseBaseTerm :: Applicative m + => (forall tp . f tp -> m (g tp)) + -> Ctx.Assignment (BaseTerm f) x + -> m (Ctx.Assignment (BaseTerm g) x) +traverseBaseTerm f = traverseFC (traverseFC f) + +-- | Traversal that performs the given action on each immediate +-- subterm of an application. Used for the 'TraversableFC' instance. +traverseApp :: forall ext m f g tp. + ( TraversableFC (ExprExtension ext) + , Applicative m + ) + => (forall u . f u -> m (g u)) + -> App ext f tp -> m (App ext g tp) +traverseApp = + $(U.structuralTraversal [t|App|] + [ + ( U.ConType [t|Ctx.Assignment|] `U.TypeApp` (U.DataArg 1) `U.TypeApp` U.AnyType + , [|traverseFC|] + ) + , (U.ConType [t|ExprExtension|] `U.TypeApp` + U.DataArg 0 `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType, + [| traverseFC |] + ) + , ( U.ConType [t|Ctx.Assignment|] + `U.TypeApp` (U.ConType [t|BaseTerm|] `U.TypeApp` (U.DataArg 1)) + `U.TypeApp` U.AnyType + , [| traverseBaseTerm |] + ) + ]) + +------------------------------------------------------------------------------ +-- Parameterized Eq and Ord instances + +instance ( TestEqualityFC (ExprExtension ext) + ) => TestEqualityFC (App ext) where + testEqualityFC testSubterm = + $(U.structuralTypeEquality [t|App|] + [ (U.DataArg 1 `U.TypeApp` U.AnyType, [|testSubterm|]) + , (U.ConType [t|Float|], + [| \x y -> if F.castFloatToWord32 x == F.castFloatToWord32 y then Just Refl else Nothing |]) + , (U.ConType [t|Double|], + [| \x y -> if F.castDoubleToWord64 x == F.castDoubleToWord64 y then Just Refl else Nothing |]) + , (U.ConType [t|ExprExtension|] `U.TypeApp` + U.DataArg 0 `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType, + [|testEqualityFC testSubterm|] + ) + , (U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|SymbolRepr |] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|BaseTypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|StringInfoRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|FloatInfoRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|StringLiteral|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|Ctx.Assignment|] `U.TypeApp` + (U.ConType [t|BaseTerm|] `U.TypeApp` U.AnyType) `U.TypeApp` U.AnyType + , [| testEqualityFC (testEqualityFC testSubterm) |] + ) + , (U.ConType [t|Ctx.Assignment|] `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType + , [| testEqualityFC testSubterm |] + ) + , (U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType + , [| testEquality |] + ) + , (U.ConType [t|Ctx.Index|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|FnHandle|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|testFnHandle|]) + , (U.ConType [t|Vector|] `U.TypeApp` U.AnyType, [|testVector testSubterm|]) + ]) + +instance ( TestEqualityFC (ExprExtension ext) + , TestEquality f + ) => TestEquality (App ext f) where + testEquality = testEqualityFC testEquality + +instance ( OrdFC (ExprExtension ext) + ) => OrdFC (App ext) where + compareFC compareSubterm + = $(U.structuralTypeOrd [t|App|] + [ (U.DataArg 1 `U.TypeApp` U.AnyType, [|compareSubterm|]) + , (U.ConType [t|Float|], + [| \x y -> fromOrdering (compare (F.castFloatToWord32 x) (F.castFloatToWord32 y)) |]) + , (U.ConType [t|Double|], + [| \x y -> fromOrdering (compare (F.castDoubleToWord64 x) (F.castDoubleToWord64 y)) |]) + , (U.ConType [t|ExprExtension|] `U.TypeApp` + U.DataArg 0 `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType, + [|compareFC compareSubterm|] + ) + , (U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|SymbolRepr |] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|BaseTypeRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|StringInfoRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|FloatInfoRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|StringLiteral|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|Ctx.Assignment|] `U.TypeApp` + (U.ConType [t|BaseTerm|] `U.TypeApp` U.AnyType) `U.TypeApp` U.AnyType + , [| compareFC (compareFC compareSubterm) |] + ) + , (U.ConType [t|Ctx.Assignment|] `U.TypeApp` U.DataArg 1 `U.TypeApp` U.AnyType + , [| compareFC compareSubterm |] + ) + , ( U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType + , [| compareF |] + ) + , (U.ConType [t|Ctx.Index|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|FnHandle|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|compareFnHandle|]) + , (U.ConType [t|Vector|] `U.TypeApp` U.AnyType, [|compareVector compareSubterm|]) + ] + ) + +instance ( OrdFC (ExprExtension ext) + , OrdF f + ) => OrdF (App ext f) where + compareF = compareFC compareF + +------------------------------------------------------------------------------------- +-- Traversals and such + +instance ( TraversableFC (ExprExtension ext) + ) => FunctorFC (App ext) where + fmapFC = fmapFCDefault + +instance ( TraversableFC (ExprExtension ext) + ) => FoldableFC (App ext) where + foldMapFC = foldMapFCDefault + +instance ( TraversableFC (ExprExtension ext) + ) => TraversableFC (App ext) where + traverseFC f = traverseApp f + +-- | Fold over an application. +foldApp :: ( TraversableFC (ExprExtension ext) + ) + => (forall x . f x -> r -> r) + -> r + -> App ext f tp + -> r +foldApp f0 r0 a = execState (traverseApp (go f0) a) r0 + where go f v = v <$ modify (f v) + +-- | Map a Crucible-type-preserving function over the immediate +-- subterms of an application. +mapApp :: ( TraversableFC (ExprExtension ext) + ) + => (forall u . f u -> g u) -> App ext f tp -> App ext g tp +mapApp f a = runIdentity (traverseApp (pure . f) a) diff --git a/src/Lang/Crucible/CFG/Extension.hs b/src/Lang/Crucible/CFG/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Extension.hs @@ -0,0 +1,140 @@ +{- | +Module : Lang.Crucible.CFG.Extension +Description : Support infrastructure for syntax extensions +Copyright : (c) Galois, Inc 2017 +License : BSD3 +Maintainer : Rob Dockins + +This module provides basic definitions necessary for handling syntax extensions +in Crucible. Syntax extensions provide a mechanism for users of the Crucible library +to add new syntactic forms to the base control-flow-graph representation of programs. + +Syntax extensions are more flexible and less tedious for some use cases than other +extension methods (e.g., override functions). +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.CFG.Extension +( ExprExtension +, StmtExtension +, IsSyntaxExtension +, PrettyApp(..) +, TypeApp(..) +, PrettyExt +, TraverseExt + + -- * Empty extension +, EmptyExprExtension +, EmptyStmtExtension +) where + +import Data.Kind (Type) +import Data.Parameterized.TraversableFC +import Prettyprinter (Doc) + +import Lang.Crucible.Types + + +class PrettyApp (app :: (k -> Type) -> k -> Type) where + ppApp :: forall f ann. (forall x. f x -> Doc ann) -> (forall x. app f x -> Doc ann) + +class TypeApp (app :: (CrucibleType -> Type) -> CrucibleType -> Type) where + appType :: app f x -> TypeRepr x + +type family ExprExtension (ext :: Type) :: (CrucibleType -> Type) -> (CrucibleType -> Type) +type family StmtExtension (ext :: Type) :: (CrucibleType -> Type) -> (CrucibleType -> Type) + +type PrettyExt ext = + ( PrettyApp (ExprExtension ext) + , PrettyApp (StmtExtension ext) + ) + +type TraverseExt ext = + ( TraversableFC (ExprExtension ext) + , TraversableFC (StmtExtension ext) + ) + +-- | This class captures all the grungy technical capabilities +-- that are needed for syntax extensions. These capabilities +-- allow syntax to be tested for equality, ordered, put into +-- hashtables, traversed and printed, etc. +-- +-- The actual meat of implementing the semantics of syntax +-- extensions is left to a later phase. See the @ExtensionImpl@ +-- record defined in "Lang.Crucible.Simulator.ExecutionTree". +class + ( OrdFC (ExprExtension ext) + , TraversableFC (ExprExtension ext) + , PrettyApp (ExprExtension ext) + , TypeApp (ExprExtension ext) + -- + , TraversableFC (StmtExtension ext) + , PrettyApp (StmtExtension ext) + , TypeApp (StmtExtension ext) + ) => + IsSyntaxExtension ext + +-- | The empty expression syntax extension, which adds no new syntactic forms. +data EmptyExprExtension :: (CrucibleType -> Type) -> (CrucibleType -> Type) + +deriving instance Show (EmptyExprExtension f tp) + +type instance ExprExtension () = EmptyExprExtension + +-- | The empty statement syntax extension, which adds no new syntactic forms. +data EmptyStmtExtension :: (CrucibleType -> Type) -> (CrucibleType -> Type) where + +deriving instance Show (EmptyStmtExtension f tp) + +type instance StmtExtension () = EmptyStmtExtension + +instance ShowFC EmptyExprExtension where + showsPrecFC _ _ = \case +instance TestEqualityFC EmptyExprExtension where + testEqualityFC _ = \case +instance OrdFC EmptyExprExtension where + compareFC _ = \case +instance HashableFC EmptyExprExtension where + hashWithSaltFC _ _ = \case +instance FunctorFC EmptyExprExtension where + fmapFC _ = \case +instance FoldableFC EmptyExprExtension where + foldMapFC _ = \case +instance TraversableFC EmptyExprExtension where + traverseFC _ = \case +instance PrettyApp EmptyExprExtension where + ppApp _ = \case +instance TypeApp EmptyExprExtension where + appType = \case + +instance ShowFC EmptyStmtExtension where + showsPrecFC _ _ = \case +instance TestEqualityFC EmptyStmtExtension where + testEqualityFC _ = \case +instance OrdFC EmptyStmtExtension where + compareFC _ = \case +instance HashableFC EmptyStmtExtension where + hashWithSaltFC _ _ = \case +instance FunctorFC EmptyStmtExtension where + fmapFC _ = \case +instance FoldableFC EmptyStmtExtension where + foldMapFC _ = \case +instance TraversableFC EmptyStmtExtension where + traverseFC _ = \case +instance PrettyApp EmptyStmtExtension where + ppApp _ = \case +instance TypeApp EmptyStmtExtension where + appType = \case + +instance IsSyntaxExtension () diff --git a/src/Lang/Crucible/CFG/ExtractSubgraph.hs b/src/Lang/Crucible/CFG/ExtractSubgraph.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/ExtractSubgraph.hs @@ -0,0 +1,226 @@ +--------------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.CFG.ExtractSubgraph +-- Description : Allows for construction of a function based off a subgraph +-- of an SSA-form function, subject to certain constraints +-- Copyright : (c) Galois, Inc 2015 +-- License : BSD3 +-- +--------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.CFG.ExtractSubgraph + ( extractSubgraph + ) where + +import Control.Lens +import qualified Data.Bimap as Bimap +import Data.Parameterized.Context as Ctx +import Data.Parameterized.Map as MapF +import Data.Set as S +import qualified Data.Map as Map +import Debug.Trace + +import What4.FunctionName +import What4.ProgramLoc + +import Lang.Crucible.CFG.Core +import Lang.Crucible.FunctionHandle + +-- | Given a CFG @cfg@, a set of blocks @cuts@ that take the return type as their sole +-- argument, and a block @bi@ that takes the CFG's init type as its sole argument, +-- construct a CFG that is a maximal subgraph starting at @bi@ and not entering any +-- block in @cuts@. If the original graph would enter a block in @cuts@, the value +-- passed to that block is returned. If @bi `member` cuts@, then whenever the subgraph +-- would transition to @bi@, it returns the value that would be passed to @bi@ instead. +extractSubgraph :: (KnownCtx TypeRepr init, KnownRepr TypeRepr ret) + => CFG ext blocks init ret + -> Set (BlockID blocks (EmptyCtx ::> ret)) + -> BlockID blocks init + -> HandleAllocator + -> IO (Maybe (SomeCFG ext init ret)) +extractSubgraph (CFG{cfgBlockMap = orig, cfgBreakpoints = breakpoints}) cuts bi halloc = + extractSubgraphFirst orig cuts MapF.empty zeroSize bi $ + \(SubgraphIntermediate finalMap finalInitMap _sz entryID cb) -> do + hn <- mkHandle halloc startFunctionName + return $ do + bm <- cb finalMap finalInitMap Ctx.empty + return $ SomeCFG $ CFG + { cfgBlockMap = bm + , cfgEntryBlockID = entryID + , cfgHandle = hn + , cfgBreakpoints = Bimap.fromList $ Map.toList $ + Map.mapMaybe (viewSome $ \bid -> Some <$> MapF.lookup bid finalMap) $ + Bimap.toMap breakpoints + } + +-- | Type for carrying intermediate results through subraph extraction +-- the interesting field is the final one - it holds a callback for transforming +-- the result of the previous portion of the subgraph extraction into the result +-- of this subgraph extraction. +data SubgraphIntermediate ext old ret init soFar new where + SubgraphIntermediate :: MapF (BlockID old) (BlockID new) + -> MapF (BlockID old) (BlockID new) + -> Size new + -> BlockID new init + -> (forall all. (MapF (BlockID old) (BlockID all) + -> MapF (BlockID old) (BlockID all) + -> Assignment (Block ext all ret) soFar + -> Maybe (Assignment (Block ext all ret) new))) + -> SubgraphIntermediate ext old ret init soFar new + + +-- | The inner loop of subgraph extraction +-- produces a callback with an existential type, in order to hide new +extractSubgraph' :: KnownRepr TypeRepr ret + => BlockMap ext old ret + -> Set (BlockID old (EmptyCtx ::> ret)) + -> MapF (BlockID old) (BlockID soFar) + -> MapF (BlockID old) (BlockID soFar) + -> Size soFar + -> BlockID old init + -> BlockID soFar args + -> forall r . (forall new. SubgraphIntermediate ext old ret args soFar new -> r) + -> r +extractSubgraph' orig cuts mapF initMap sz bi ident f = + let block = getBlock bi orig + in withBlockTermStmt block $ (\_ t -> + (case t of + Jump (JumpTarget bi' _ _) -> \sgi -> visitChildNode orig cuts bi' sgi f + Br _ (JumpTarget bi1 _ _) (JumpTarget bi2 _ _) -> \sgi1 -> + visitChildNode orig cuts bi1 sgi1 + $ \sgi2 -> visitChildNode orig cuts bi2 sgi2 f + Return _ -> f + _ -> error "extractSubgraph': unexpected case!") + (SubgraphIntermediate + (MapF.insert bi (BlockID $ nextIndex sz) (MapF.map extendBlockID mapF)) + (MapF.map extendBlockID initMap) + (incSize sz) + (extendBlockID ident) + (\finalMap _finalInitMap assn -> + fmap (extend assn) (do + finalID <- MapF.lookup bi finalMap + cloneBlock finalMap finalID block)))) + +-- code duplication... but the types need to be different between iterations +-- FIXME: write a generic version that this and extractSubgraph' can be wrappers +-- around +extractSubgraphFirst :: KnownRepr TypeRepr ret + => BlockMap ext old ret + -> Set (BlockID old (EmptyCtx ::> ret)) + -> MapF (BlockID old) (BlockID soFar) + -> Size soFar + -> BlockID old init + -> forall r . (forall new. SubgraphIntermediate ext old ret init soFar new -> r) + -> r +extractSubgraphFirst orig cuts mapF sz bi f = + let block = getBlock bi orig + in withBlockTermStmt block $ (\_ t -> + (case t of + Jump (JumpTarget bi' _ _) -> \sgi -> visitChildNode orig cuts bi' sgi f + Br _ (JumpTarget bi1 _ _) (JumpTarget bi2 _ _) -> \sgi1 -> + visitChildNode orig cuts bi1 sgi1 + $ \sgi2 -> visitChildNode orig cuts bi2 sgi2 f + Return _ -> f + _ -> error "extractSubgraphFirst: unexpected case!") + (SubgraphIntermediate + (if case S.minView cuts of + Just (bi', _) -> case testEquality (blockInputs block) (blockInputs $ orig Ctx.! blockIDIndex bi') of + Just Refl -> bi `S.member` cuts + Nothing -> False + Nothing -> False + then MapF.map extendBlockID mapF + else MapF.insert bi (BlockID $ nextIndex sz) (MapF.map extendBlockID mapF)) + (MapF.insert bi (BlockID $ nextIndex sz) (MapF.map extendBlockID mapF)) + (incSize sz) + (BlockID $ nextIndex sz) + (\finalMap finalInitMap assn -> fmap (extend assn) (do + finalID <- MapF.lookup bi finalInitMap + cloneBlock finalMap finalID block)))) + +-- does the building of a new node - mutually recursive with exrtactSubgraph' +visitChildNode :: KnownRepr TypeRepr ret + => BlockMap ext old ret + -> Set (BlockID old (EmptyCtx ::> ret)) + -> BlockID old init + -> SubgraphIntermediate ext old ret args soFar prev + -> (forall r. (forall new . SubgraphIntermediate ext old ret args soFar new -> r) + -> r) +visitChildNode orig cuts bi (SubgraphIntermediate sgMap initMap sz ident cb) f= + case MapF.lookup bi sgMap of + Just _bi' -> f $ SubgraphIntermediate sgMap initMap sz ident cb + Nothing -> case S.minView cuts of + Just (cut, _) + | Just Refl <- testEquality (blockInputs $ orig Ctx.! blockIDIndex bi) (blockInputs $ orig Ctx.! blockIDIndex cut) + , S.member bi cuts -> + f $ SubgraphIntermediate + (MapF.insert bi (BlockID $ nextIndex sz) (MapF.map extendBlockID sgMap)) + (MapF.map extendBlockID initMap) + (incSize sz) + (extendBlockID ident) + (\finalMap finalCutMap assn -> do + assn' <- cb finalMap finalCutMap assn + newBlock <- mkRetBlock finalMap orig bi + return $ extend assn' newBlock) + _ -> extractSubgraph' orig cuts sgMap initMap sz bi ident + (\ (SubgraphIntermediate sgMap' initMap' sz' ident' ccb) -> + f $ SubgraphIntermediate sgMap' initMap' sz' ident' + (\finalMap finalCutMap assn -> + ccb finalMap finalCutMap =<< cb finalMap finalCutMap assn)) + + +mkRetBlock :: MapF (BlockID old) (BlockID new) + -> BlockMap ext old ret + -> BlockID old (EmptyCtx ::> ret) + -> Maybe (Block ext new ret (EmptyCtx ::> ret)) +mkRetBlock mapF bm ident = + case MapF.lookup ident mapF of + Just id' -> + let block = bm Ctx.! blockIDIndex ident + in Just $ + let name = plFunction (blockLoc block) + term = Return lastReg + in Block{ blockID = id' + , blockInputs = blockInputs block + , _blockStmts = TermStmt (mkProgramLoc name InternalPos) term + } + Nothing -> trace ("could not lookup return block id " ++ show (blockIDIndex ident)) Nothing + + +cloneBlock :: MapF (BlockID old) (BlockID new) + -> BlockID new ctx -> Block ext old ret ctx -> Maybe (Block ext new ret ctx) +cloneBlock mapF newID b = do + stmts' <- cloneStmtSeq mapF (b^.blockStmts) + return Block{ blockID = newID + , blockInputs = blockInputs b + , _blockStmts = stmts' + } + +cloneStmtSeq :: MapF (BlockID old) (BlockID new) -> StmtSeq ext old ret ctx -> Maybe (StmtSeq ext new ret ctx) +cloneStmtSeq mapF (ConsStmt loc stmt rest) = do + rest' <- cloneStmtSeq mapF rest + return $ ConsStmt loc stmt rest' +cloneStmtSeq mapF (TermStmt loc term) = do + term' <- cloneTerm mapF term + return $ TermStmt loc term' + +cloneTerm :: MapF (BlockID old) (BlockID new) -> TermStmt old ret ctx -> Maybe (TermStmt new ret ctx) +cloneTerm mapF (Jump jt) = fmap Jump $ cloneJumpTarget mapF jt +cloneTerm mapF (Br reg jt1 jt2) = do + jt1' <- cloneJumpTarget mapF jt1 + jt2' <- cloneJumpTarget mapF jt2 + return $ Br reg jt1' jt2' +cloneTerm _mapF (Return reg) = Just $ Return reg +cloneTerm _ _ = error "cloneTerm: unexpected case!" + +cloneJumpTarget :: MapF (BlockID blocks1) (BlockID blocks2) + -> JumpTarget blocks1 t + -> Maybe (JumpTarget blocks2 t) +cloneJumpTarget mapF (JumpTarget ident args assn) = do + case MapF.lookup ident mapF of + Just id' -> Just $ JumpTarget id' args assn + Nothing -> trace ("could not lookup jump target id " ++ show (blockIDIndex ident)) Nothing diff --git a/src/Lang/Crucible/CFG/Generator.hs b/src/Lang/Crucible/CFG/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Generator.hs @@ -0,0 +1,956 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.CFG.Generator +-- Description : Provides a monadic interface for constructing Crucible +-- control flow graphs. +-- Copyright : (c) Galois, Inc 2014-2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides a monadic interface for constructing control flow +-- graph expressions. The goal is to make it easy to convert languages +-- into CFGs. +-- +-- The CFGs generated by this interface are similar to, but not quite +-- the same as, the CFGs defined in "Lang.Crucible.CFG.Core". The +-- module "Lang.Crucible.CFG.SSAConversion" contains code that +-- converts the CFGs produced by this interface into Core CFGs in SSA +-- form. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.CFG.Generator + ( -- * Generator + Generator + , FunctionDef + , defineFunction + , defineFunctionOpt + -- * Positions + , getPosition + , setPosition + , withPosition + -- * Expressions and statements + , newReg + , newUnassignedReg + , readReg + , assignReg + , modifyReg + , modifyRegM + , readGlobal + , writeGlobal + -- * References + , newRef + , newEmptyRef + , readRef + , writeRef + , dropRef + , call + , assertExpr + , assumeExpr + , addPrintStmt + , addBreakpointStmt + , extensionStmt + , mkAtom + , mkFresh + , mkFreshFloat + , forceEvaluation + -- * Labels + , newLabel + , newLambdaLabel + , newLambdaLabel' + , currentBlockID + -- * Block-terminating statements + -- $termstmt + , jump + , jumpToLambda + , branch + , returnFromFunction + , reportError + , branchMaybe + , branchVariant + , tailCall + -- * Defining blocks + -- $define + , defineBlock + , defineLambdaBlock + , defineBlockLabel + , recordCFG + -- * Control-flow combinators + , continue + , continueLambda + , whenCond + , unlessCond + , ifte + , ifte' + , ifte_ + , ifteM + , MatchMaybe(..) + , caseMaybe + , caseMaybe_ + , fromJustExpr + , assertedJustExpr + , while + -- * Re-exports + , Ctx.Ctx(..) + , Position + , module Lang.Crucible.CFG.Reg + , module Lang.Crucible.CFG.EarlyMergeLoops + ) where + +import Control.Lens hiding (Index) +import Control.Monad ((>=>)) +import qualified Control.Monad.Fail as F +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Strict () +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Catch +import qualified Data.Foldable as Fold +import Data.Kind +import Data.Parameterized.Context as Ctx +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Void + +import What4.ProgramLoc +import What4.Symbol + +import Lang.Crucible.CFG.Core (AnyCFG(..)) +import Lang.Crucible.CFG.Expr(App(..)) +import Lang.Crucible.CFG.Extension +import Lang.Crucible.CFG.Reg hiding (AnyCFG) +import Lang.Crucible.CFG.EarlyMergeLoops (earlyMergeLoops) +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types +import Lang.Crucible.Utils.StateContT + +------------------------------------------------------------------------ +-- CurrentBlockState + +-- | A sequence of statements. +type StmtSeq ext s = Seq (Posd (Stmt ext s)) + +-- | Information about block being generated in Generator. +data CurrentBlockState ext s + = CBS { -- | Identifier for current block + cbsBlockID :: !(BlockID s) + , cbsInputValues :: !(ValueSet s) + , _cbsStmts :: !(StmtSeq ext s) + } + +initCurrentBlockState :: ValueSet s -> BlockID s -> CurrentBlockState ext s +initCurrentBlockState inputs block_id = + CBS { cbsBlockID = block_id + , cbsInputValues = inputs + , _cbsStmts = Seq.empty + } + +-- | Statements translated so far in this block. +cbsStmts :: Simple Lens (CurrentBlockState ext s) (StmtSeq ext s) +cbsStmts = lens _cbsStmts (\s v -> s { _cbsStmts = v }) + +------------------------------------------------------------------------ +-- GeneratorState + +-- | State for translating within a basic block. +data IxGeneratorState ext s (t :: Type -> Type) ret m i + = GS { _gsEntryLabel :: !(Label s) + , _gsBlocks :: !(Seq (Block ext s ret)) + , _gsNonceGen :: !(NonceGenerator m s) + , _gsCurrent :: !i + , _gsPosition :: !Position + , _gsState :: !(t s) + , _seenFunctions :: ![AnyCFG ext] + } + +type GeneratorState ext s t ret m = + IxGeneratorState ext s t ret m (CurrentBlockState ext s) + +type EndState ext s t ret m = + IxGeneratorState ext s t ret m () + +-- | Label for entry block. +gsEntryLabel :: Getter (IxGeneratorState ext s t ret m i) (Label s) +gsEntryLabel = to _gsEntryLabel + +-- | List of previously processed blocks. +gsBlocks :: Simple Lens (IxGeneratorState ext s t ret m i) (Seq (Block ext s ret)) +gsBlocks = lens _gsBlocks (\s v -> s { _gsBlocks = v }) + +gsNonceGen :: Getter (IxGeneratorState ext s t ret m i) (NonceGenerator m s) +gsNonceGen = to _gsNonceGen + +-- | Information about current block. +gsCurrent :: Lens (IxGeneratorState ext s t ret m i) (IxGeneratorState ext s t ret m j) i j +gsCurrent = lens _gsCurrent (\s v -> s { _gsCurrent = v }) + +-- | Current source position. +gsPosition :: Simple Lens (IxGeneratorState ext s t ret m i) Position +gsPosition = lens _gsPosition (\s v -> s { _gsPosition = v }) + +-- | User state for current block. This gets reset between blocks. +gsState :: Simple Lens (IxGeneratorState ext s t ret m i) (t s) +gsState = lens _gsState (\s v -> s { _gsState = v }) + +-- | List of functions seen by current generator. +seenFunctions :: Simple Lens (IxGeneratorState ext s t ret m i) [AnyCFG ext] +seenFunctions = lens _seenFunctions (\s v -> s { _seenFunctions = v }) + +------------------------------------------------------------------------ + +startBlock :: + BlockID s -> + EndState ext s t ret m -> + GeneratorState ext s t ret m +startBlock l gs = + gs & gsCurrent .~ initCurrentBlockState Set.empty l + +-- | Define the current block by defining the position and final +-- statement. +terminateBlock :: + IsSyntaxExtension ext => + TermStmt s ret -> + GeneratorState ext s t ret m -> + EndState ext s t ret m +terminateBlock term gs = + do let p = gs^.gsPosition + let cbs = gs^.gsCurrent + -- Define block + let b = mkBlock (cbsBlockID cbs) (cbsInputValues cbs) (cbs^.cbsStmts) (Posd p term) + -- Store block + let gs' = gs & gsCurrent .~ () + & gsBlocks %~ (Seq.|> b) + seq b gs' + +------------------------------------------------------------------------ +-- Generator + +-- | A generator is used for constructing a CFG from a sequence of +-- monadic actions. +-- +-- The 'ext' parameter indicates the syntax extension. +-- The 's' parameter is the phantom parameter for CFGs. +-- The 't' parameter is the parameterized type that allows user-defined +-- state. +-- The 'ret' parameter is the return type of the CFG. +-- The 'm' parameter is a monad over which the generator is lifted +-- The 'a' parameter is the value returned by the monad. + +newtype Generator ext s (t :: Type -> Type) (ret :: CrucibleType) m a + = Generator { unGenerator :: StateContT (GeneratorState ext s t ret m) + (EndState ext s t ret m) + m + a + } + deriving ( Functor + , Applicative + , MonadThrow + , MonadCatch + ) + +instance MonadTrans (Generator ext s t ret) where + lift m = Generator (lift m) + +instance Monad m => Monad (Generator ext s t ret m) where + x >>= f = Generator (unGenerator x >>= unGenerator . f) + +instance F.MonadFail m => F.MonadFail (Generator ext s t ret m) where + fail msg = Generator $ do + p <- use gsPosition + fail $ unwords [ "Failure encountered while generating a Crucible CFG:" + , "at " ++ show p ++ ": " ++ msg + ] + +instance Monad m => MonadState (t s) (Generator ext s t ret m) where + get = Generator $ use gsState + put v = Generator $ gsState .= v + +instance MonadIO m => MonadIO (Generator ext s t ret m) where + liftIO m = lift (liftIO m) + +-- This function only works for 'Generator' actions that terminate +-- early, i.e. do not call their continuation. This includes actions +-- that end with block-terminating statements defined with +-- 'terminateEarly'. +runGenerator :: + Generator ext s t ret m Void -> + GeneratorState ext s t ret m -> + m (EndState ext s t ret m) +runGenerator m gs = runStateContT (unGenerator m) absurd gs + +-- | Get the current position. +getPosition :: Generator ext s t ret m Position +getPosition = Generator $ use gsPosition + +-- | Set the current position. +setPosition :: Position -> Generator ext s t ret m () +setPosition p = Generator $ gsPosition .= p + +-- | Set the current position temporarily, and reset it afterwards. +withPosition :: Monad m + => Position + -> Generator ext s t ret m a + -> Generator ext s t ret m a +withPosition p m = + do old_pos <- getPosition + setPosition p + v <- m + setPosition old_pos + return v + +mkNonce :: Monad m => Generator ext s t ret m (Nonce s tp) +mkNonce = + do ng <- Generator $ use gsNonceGen + Generator $ lift $ freshNonce ng + +---------------------------------------------------------------------- +-- Expressions and statements + +addStmt :: Monad m => Stmt ext s -> Generator ext s t ret m () +addStmt s = + do p <- getPosition + cbs <- Generator $ use gsCurrent + let ps = Posd p s + let cbs' = cbs & cbsStmts %~ (Seq.|> ps) + seq ps $ seq cbs' $ Generator $ gsCurrent .= cbs' + +freshAtom :: (Monad m, IsSyntaxExtension ext) => AtomValue ext s tp -> Generator ext s t ret m (Atom s tp) +freshAtom av = + do p <- getPosition + n <- mkNonce + let atom = Atom { atomPosition = p + , atomId = n + , atomSource = Assigned + , typeOfAtom = typeOfAtomValue av + } + addStmt (DefineAtom atom av) + return atom + + +mkFresh :: (Monad m, IsSyntaxExtension ext) + => BaseTypeRepr tp + -> Maybe SolverSymbol + -> Generator ext s t ret m (Atom s (BaseToType tp)) +mkFresh tr symb = freshAtom (FreshConstant tr symb) + +mkFreshFloat :: (Monad m, IsSyntaxExtension ext) + => FloatInfoRepr fi + -> Maybe SolverSymbol + -> Generator ext s t ret m (Atom s (FloatType fi)) +mkFreshFloat fi symb = freshAtom (FreshFloat fi symb) + +-- | Create an atom equivalent to the given expression if it is +-- not already an 'AtomExpr'. +mkAtom :: (Monad m, IsSyntaxExtension ext) => Expr ext s tp -> Generator ext s t ret m (Atom s tp) +mkAtom (AtomExpr a) = return a +mkAtom (App a) = freshAtom . EvalApp =<< traverseFC mkAtom a + +-- | Read a global variable. +readGlobal :: (Monad m, IsSyntaxExtension ext) => GlobalVar tp -> Generator ext s t ret m (Expr ext s tp) +readGlobal v = AtomExpr <$> freshAtom (ReadGlobal v) + +-- | Write to a global variable. +writeGlobal :: (Monad m, IsSyntaxExtension ext) => GlobalVar tp -> Expr ext s tp -> Generator ext s t ret m () +writeGlobal v e = + do a <- mkAtom e + addStmt (WriteGlobal v a) + +-- | Read the current value of a reference cell. +readRef :: (Monad m, IsSyntaxExtension ext) => Expr ext s (ReferenceType tp) -> Generator ext s t ret m (Expr ext s tp) +readRef ref = + do r <- mkAtom ref + AtomExpr <$> freshAtom (ReadRef r) + +-- | Write the given value into the reference cell. +writeRef :: (Monad m, IsSyntaxExtension ext) => Expr ext s (ReferenceType tp) -> Expr ext s tp -> Generator ext s t ret m () +writeRef ref val = + do r <- mkAtom ref + v <- mkAtom val + addStmt (WriteRef r v) + +-- | Deallocate the given reference cell, returning it to an uninialized state. +-- The reference cell can still be used; subsequent writes will succeed, +-- and reads will succeed if some value is written first. +dropRef :: (Monad m, IsSyntaxExtension ext) => Expr ext s (ReferenceType tp) -> Generator ext s t ret m () +dropRef ref = + do r <- mkAtom ref + addStmt (DropRef r) + +-- | Generate a new reference cell with the given initial contents. +newRef :: (Monad m, IsSyntaxExtension ext) => Expr ext s tp -> Generator ext s t ret m (Expr ext s (ReferenceType tp)) +newRef val = + do v <- mkAtom val + AtomExpr <$> freshAtom (NewRef v) + +-- | Generate a new empty reference cell. If an unassigned reference is later +-- read, it will generate a runtime error. +newEmptyRef :: (Monad m, IsSyntaxExtension ext) => TypeRepr tp -> Generator ext s t ret m (Expr ext s (ReferenceType tp)) +newEmptyRef tp = + AtomExpr <$> freshAtom (NewEmptyRef tp) + +-- | Generate a new virtual register with the given initial value. +newReg :: (Monad m, IsSyntaxExtension ext) => Expr ext s tp -> Generator ext s t ret m (Reg s tp) +newReg e = + do r <- newUnassignedReg (exprType e) + assignReg r e + return r + +-- | Produce a new virtual register without giving it an initial value. +-- NOTE! If you fail to initialize this register with a subsequent +-- call to @assignReg@, errors will arise during SSA conversion. +newUnassignedReg :: Monad m => TypeRepr tp -> Generator ext s t ret m (Reg s tp) +newUnassignedReg tp = + do p <- getPosition + n <- mkNonce + return $! Reg { regPosition = p + , regId = n + , typeOfReg = tp + } + +-- | Get the current value of a register. +readReg :: (Monad m, IsSyntaxExtension ext) => Reg s tp -> Generator ext s t ret m (Expr ext s tp) +readReg r = AtomExpr <$> freshAtom (ReadReg r) + +-- | Update the value of a register. +assignReg :: (Monad m, IsSyntaxExtension ext) => Reg s tp -> Expr ext s tp -> Generator ext s t ret m () +assignReg r e = + do a <- mkAtom e + addStmt (SetReg r a) + +-- | Modify the value of a register. +modifyReg :: (Monad m, IsSyntaxExtension ext) => Reg s tp -> (Expr ext s tp -> Expr ext s tp) -> Generator ext s t ret m () +modifyReg r f = + do v <- readReg r + assignReg r $! f v + +-- | Modify the value of a register. +modifyRegM :: (Monad m, IsSyntaxExtension ext) + => Reg s tp + -> (Expr ext s tp -> Generator ext s t ret m (Expr ext s tp)) + -> Generator ext s t ret m () +modifyRegM r f = + do v <- readReg r + v' <- f v + assignReg r v' + +-- | Add a statement to print a value. +addPrintStmt :: (Monad m, IsSyntaxExtension ext) => Expr ext s (StringType Unicode) -> Generator ext s t ret m () +addPrintStmt e = + do e_a <- mkAtom e + addStmt (Print e_a) + +-- | Add a breakpoint. +addBreakpointStmt :: + (Monad m, IsSyntaxExtension ext) => + Text {- ^ breakpoint name -} -> + Assignment (Value s) args {- ^ breakpoint values -} -> + Generator ext s t r m () +addBreakpointStmt nm args = addStmt $ Breakpoint (BreakpointName nm) args + +-- | Add an assert statement. +assertExpr :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s BoolType {- ^ assertion -} -> + Expr ext s (StringType Unicode) {- ^ error message -} -> + Generator ext s t ret m () +assertExpr b e = + do b_a <- mkAtom b + e_a <- mkAtom e + addStmt (Assert b_a e_a) + +-- | Add an assume statement. +assumeExpr :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s BoolType {- ^ assumption -} -> + Expr ext s (StringType Unicode) {- ^ reason message -} -> + Generator ext s t ret m () +assumeExpr b e = + do b_a <- mkAtom b + m_a <- mkAtom e + addStmt (Assume b_a m_a) + + +-- | Stash the given CFG away for later retrieval. This is primarily +-- used when translating inner and anonymous functions in the +-- context of an outer function. +recordCFG :: AnyCFG ext -> Generator ext s t ret m () +recordCFG g = Generator $ seenFunctions %= (g:) + +------------------------------------------------------------------------ +-- Labels + +-- | Create a new block label. +newLabel :: Monad m => Generator ext s t ret m (Label s) +newLabel = Label <$> mkNonce + +-- | Create a new lambda label. +newLambdaLabel :: Monad m => KnownRepr TypeRepr tp => Generator ext s t ret m (LambdaLabel s tp) +newLambdaLabel = newLambdaLabel' knownRepr + +-- | Create a new lambda label, using an explicit 'TypeRepr'. +newLambdaLabel' :: Monad m => TypeRepr tp -> Generator ext s t ret m (LambdaLabel s tp) +newLambdaLabel' tpr = + do p <- getPosition + idx <- mkNonce + i <- mkNonce + let lbl = LambdaLabel idx a + a = Atom { atomPosition = p + , atomId = i + , atomSource = LambdaArg lbl + , typeOfAtom = tpr + } + return $! lbl + +-- | Return the label of the current basic block. +currentBlockID :: Generator ext s t ret m (BlockID s) +currentBlockID = + Generator $ + (\st -> st ^. gsCurrent & cbsBlockID) <$> get + +---------------------------------------------------------------------- +-- Defining blocks + +-- $define The block-defining commands should be used with a +-- 'Generator' action ending with a block-terminating statement, which +-- gives it a polymorphic type. + +-- | End the translation of the current block, and then continue +-- generating a new block with the given label. +continue :: + (Monad m, IsSyntaxExtension ext) => + Label s {- ^ label for new block -} -> + (forall a. Generator ext s t ret m a) {- ^ action to end current block -} -> + Generator ext s t ret m () +continue lbl action = + Generator $ StateContT $ \cont gs -> + do gs' <- runGenerator action gs + cont () (startBlock (LabelID lbl) gs') + +-- | End the translation of the current block, and then continue +-- generating a new lambda block with the given label. The return +-- value is the argument to the lambda block. +continueLambda :: + (Monad m, IsSyntaxExtension ext) => + LambdaLabel s tp {- ^ label for new block -} -> + (forall a. Generator ext s t ret m a) {- ^ action to end current block -} -> + Generator ext s t ret m (Expr ext s tp) +continueLambda lbl action = + Generator $ StateContT $ \cont gs -> + do gs' <- runGenerator action gs + cont (AtomExpr (lambdaAtom lbl)) (startBlock (LambdaID lbl) gs') + +defineSomeBlock :: + (Monad m, IsSyntaxExtension ext) => + BlockID s -> + Generator ext s t ret m Void -> + Generator ext s t ret m () +defineSomeBlock l next = + Generator $ StateContT $ \cont gs0 -> + do let gs1 = startBlock l (gs0 & gsCurrent .~ ()) + gs2 <- runGenerator next gs1 + -- Reset current block and state. + let gs3 = gs2 & gsPosition .~ gs0^.gsPosition + & gsCurrent .~ gs0^.gsCurrent + cont () gs3 + +-- | Define a block with an ordinary label. +defineBlock :: + (Monad m, IsSyntaxExtension ext) => + Label s -> + (forall a. Generator ext s t ret m a) -> + Generator ext s t ret m () +defineBlock l action = + defineSomeBlock (LabelID l) action + +-- | Define a block that has a lambda label. +defineLambdaBlock :: + (Monad m, IsSyntaxExtension ext) => + LambdaLabel s tp -> + (forall a. Expr ext s tp -> Generator ext s t ret m a) -> + Generator ext s t ret m () +defineLambdaBlock l action = + defineSomeBlock (LambdaID l) (action (AtomExpr (lambdaAtom l))) + +-- | Define a block with a fresh label, returning the label. +defineBlockLabel :: + (Monad m, IsSyntaxExtension ext) => + (forall a. Generator ext s t ret m a) -> + Generator ext s t ret m (Label s) +defineBlockLabel action = + do l <- newLabel + defineBlock l action + return l + +------------------------------------------------------------------------ +-- Generator interface + +-- | Evaluate an expression to an 'AtomExpr', so that it can be reused multiple times later. +forceEvaluation :: (Monad m, IsSyntaxExtension ext) => Expr ext s tp -> Generator ext s t ret m (Expr ext s tp) +forceEvaluation e = AtomExpr <$> mkAtom e + +-- | Add a statement from the syntax extension to the current basic block. +extensionStmt :: + (Monad m, IsSyntaxExtension ext) => + StmtExtension ext (Expr ext s) tp -> + Generator ext s t ret m (Expr ext s tp) +extensionStmt stmt = do + stmt' <- traverseFC mkAtom stmt + AtomExpr <$> freshAtom (EvalExt stmt') + +-- | Call a function. +call :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (FunctionHandleType args ret) {- ^ function to call -} + -> Assignment (Expr ext s) args {- ^ function arguments -} + -> Generator ext s t r m (Expr ext s ret) +call h args = AtomExpr <$> call' h args + +-- | Call a function. +call' :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (FunctionHandleType args ret) + -> Assignment (Expr ext s) args + -> Generator ext s t r m (Atom s ret) +call' h args = do + case exprType h of + FunctionHandleRepr _ retType -> do + h_a <- mkAtom h + args_a <- traverseFC mkAtom args + freshAtom $ Call h_a args_a retType + +---------------------------------------------------------------------- +-- Block-terminating statements + +-- $termstmt The following operations produce block-terminating +-- statements, and have early termination behavior in the 'Generator' +-- monad: Like 'fail', they have polymorphic return types and cause +-- any following monadic actions to be skipped. + +-- | End the current block with the given terminal statement, and skip +-- the rest of the 'Generator' computation. +terminateEarly :: + (Monad m, IsSyntaxExtension ext) => TermStmt s ret -> Generator ext s t ret m a +terminateEarly term = + Generator $ StateContT $ \_cont gs -> + return (terminateBlock term gs) + +-- | Jump to the given label. +jump :: (Monad m, IsSyntaxExtension ext) => Label s -> Generator ext s t ret m a +jump l = terminateEarly (Jump l) + +-- | Jump to the given label with output. +jumpToLambda :: + (Monad m, IsSyntaxExtension ext) => + LambdaLabel s tp -> + Expr ext s tp -> + Generator ext s t ret m a +jumpToLambda lbl v = do + v_a <- mkAtom v + terminateEarly (Output lbl v_a) + +-- | Branch between blocks. +branch :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s BoolType {- ^ condition -} -> + Label s {- ^ true label -} -> + Label s {- ^ false label -} -> + Generator ext s t ret m a +branch (App (Not e)) x_id y_id = do + branch e y_id x_id +branch e x_id y_id = do + a <- mkAtom e + terminateEarly (Br a x_id y_id) + +-- | Return from this function with the given return value. +returnFromFunction :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s ret -> Generator ext s t ret m a +returnFromFunction e = do + e_a <- mkAtom e + terminateEarly (Return e_a) + +-- | Report an error message. +reportError :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s (StringType Unicode) -> Generator ext s t ret m a +reportError e = do + e_a <- mkAtom e + terminateEarly (ErrorStmt e_a) + +-- | Branch between blocks based on a @Maybe@ value. +branchMaybe :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s (MaybeType tp) -> + LambdaLabel s tp {- ^ label for @Just@ -} -> + Label s {- ^ label for @Nothing@ -} -> + Generator ext s t ret m a +branchMaybe v l1 l2 = + case exprType v of + MaybeRepr etp -> + do v_a <- mkAtom v + terminateEarly (MaybeBranch etp v_a l1 l2) + +-- | Switch on a variant value. Examine the tag of the variant and +-- jump to the appropriate switch target. +branchVariant :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s (VariantType varctx) {- ^ value to scrutinize -} -> + Assignment (LambdaLabel s) varctx {- ^ target labels -} -> + Generator ext s t ret m a +branchVariant v lbls = + case exprType v of + VariantRepr typs -> + do v_a <- mkAtom v + terminateEarly (VariantElim typs v_a lbls) + +-- | End a block with a tail call to a function. +tailCall :: + (Monad m, IsSyntaxExtension ext) => + Expr ext s (FunctionHandleType args ret) {- ^ function to call -} -> + Assignment (Expr ext s) args {- ^ function arguments -} -> + Generator ext s t ret m a +tailCall h args = + case exprType h of + FunctionHandleRepr argTypes _retType -> + do h_a <- mkAtom h + args_a <- traverseFC mkAtom args + terminateEarly (TailCall h_a argTypes args_a) + +------------------------------------------------------------------------ +-- Combinators + +-- | Expression-level if-then-else. +ifte :: (Monad m, IsSyntaxExtension ext, KnownRepr TypeRepr tp) + => Expr ext s BoolType + -> Generator ext s t ret m (Expr ext s tp) -- ^ true branch + -> Generator ext s t ret m (Expr ext s tp) -- ^ false branch + -> Generator ext s t ret m (Expr ext s tp) +ifte e x y = do + c_id <- newLambdaLabel + x_id <- defineBlockLabel $ x >>= jumpToLambda c_id + y_id <- defineBlockLabel $ y >>= jumpToLambda c_id + continueLambda c_id (branch e x_id y_id) + +ifte' :: (Monad m, IsSyntaxExtension ext) + => TypeRepr tp + -> Expr ext s BoolType + -> Generator ext s t ret m (Expr ext s tp) -- ^ true branch + -> Generator ext s t ret m (Expr ext s tp) -- ^ false branch + -> Generator ext s t ret m (Expr ext s tp) +ifte' repr e x y = do + c_id <- newLambdaLabel' repr + x_id <- defineBlockLabel $ x >>= jumpToLambda c_id + y_id <- defineBlockLabel $ y >>= jumpToLambda c_id + continueLambda c_id (branch e x_id y_id) + +-- | Statement-level if-then-else. +ifte_ :: (Monad m, IsSyntaxExtension ext) + => Expr ext s BoolType + -> Generator ext s t ret m () -- ^ true branch + -> Generator ext s t ret m () -- ^ false branch + -> Generator ext s t ret m () +ifte_ e x y = do + c_id <- newLabel + x_id <- defineBlockLabel $ x >> jump c_id + y_id <- defineBlockLabel $ y >> jump c_id + continue c_id (branch e x_id y_id) + +-- | Expression-level if-then-else with a monadic condition. +ifteM :: (Monad m, IsSyntaxExtension ext, KnownRepr TypeRepr tp) + => Generator ext s t ret m (Expr ext s BoolType) + -> Generator ext s t ret m (Expr ext s tp) -- ^ true branch + -> Generator ext s t ret m (Expr ext s tp) -- ^ false branch + -> Generator ext s t ret m (Expr ext s tp) +ifteM em x y = do { m <- em; ifte m x y } + +-- | Run a computation when a condition is true. +whenCond :: (Monad m, IsSyntaxExtension ext) + => Expr ext s BoolType + -> Generator ext s t ret m () + -> Generator ext s t ret m () +whenCond e x = do + c_id <- newLabel + t_id <- defineBlockLabel $ x >> jump c_id + continue c_id (branch e t_id c_id) + +-- | Run a computation when a condition is false. +unlessCond :: (Monad m, IsSyntaxExtension ext) + => Expr ext s BoolType + -> Generator ext s t ret m () + -> Generator ext s t ret m () +unlessCond e x = do + c_id <- newLabel + f_id <- defineBlockLabel $ x >> jump c_id + continue c_id (branch e c_id f_id) + +data MatchMaybe j r + = MatchMaybe + { onJust :: j -> r + , onNothing :: r + } + +-- | Compute an expression by cases over a @Maybe@ value. +caseMaybe :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (MaybeType tp) {- ^ expression to scrutinize -} + -> TypeRepr r {- ^ result type -} + -> MatchMaybe (Expr ext s tp) (Generator ext s t ret m (Expr ext s r)) {- ^ case branches -} + -> Generator ext s t ret m (Expr ext s r) +caseMaybe v retType cases = do + let etp = case exprType v of + MaybeRepr etp' -> etp' + j_id <- newLambdaLabel' etp + n_id <- newLabel + c_id <- newLambdaLabel' retType + defineLambdaBlock j_id $ onJust cases >=> jumpToLambda c_id + defineBlock n_id $ onNothing cases >>= jumpToLambda c_id + continueLambda c_id (branchMaybe v j_id n_id) + +-- | Evaluate different statements by cases over a @Maybe@ value. +caseMaybe_ :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (MaybeType tp) {- ^ expression to scrutinize -} + -> MatchMaybe (Expr ext s tp) (Generator ext s t ret m ()) {- ^ case branches -} + -> Generator ext s t ret m () +caseMaybe_ v cases = do + let etp = case exprType v of + MaybeRepr etp' -> etp' + j_id <- newLambdaLabel' etp + n_id <- newLabel + c_id <- newLabel + defineLambdaBlock j_id $ \e -> onJust cases e >> jump c_id + defineBlock n_id $ onNothing cases >> jump c_id + continue c_id (branchMaybe v j_id n_id) + +-- | Return the argument of a @Just@ value, or call 'reportError' if +-- the value is @Nothing@. +fromJustExpr :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (MaybeType tp) + -> Expr ext s (StringType Unicode) {- ^ error message -} + -> Generator ext s t ret m (Expr ext s tp) +fromJustExpr e msg = do + let etp = case exprType e of + MaybeRepr etp' -> etp' + j_id <- newLambdaLabel' etp + n_id <- newLabel + c_id <- newLambdaLabel' etp + defineLambdaBlock j_id $ jumpToLambda c_id + defineBlock n_id $ reportError msg + continueLambda c_id (branchMaybe e j_id n_id) + +-- | This asserts that the value in the expression is a @Just@ value, and +-- returns the underlying value. +assertedJustExpr :: (Monad m, IsSyntaxExtension ext) + => Expr ext s (MaybeType tp) + -> Expr ext s (StringType Unicode) {- ^ error message -} + -> Generator ext s t ret m (Expr ext s tp) +assertedJustExpr e msg = + case exprType e of + MaybeRepr tp -> + forceEvaluation $! App (FromJustValue tp e msg) + +-- | Execute the loop body as long as the test condition is true. +while :: (Monad m, IsSyntaxExtension ext) + => (Position, Generator ext s t ret m (Expr ext s BoolType)) {- ^ test condition -} + -> (Position, Generator ext s t ret m ()) {- ^ loop body -} + -> Generator ext s t ret m () +while (pcond,cond) (pbody,body) = do + cond_lbl <- newLabel + loop_lbl <- newLabel + exit_lbl <- newLabel + + withPosition pcond $ + defineBlock cond_lbl $ do + b <- cond + branch b loop_lbl exit_lbl + + withPosition pbody $ + defineBlock loop_lbl $ do + body + jump cond_lbl + + continue exit_lbl (jump cond_lbl) + +------------------------------------------------------------------------ +-- CFG + +cfgFromGenerator :: FnHandle init ret + -> IxGeneratorState ext s t ret m i + -> CFG ext s init ret +cfgFromGenerator h s = + CFG { cfgHandle = h + , cfgEntryLabel = s^.gsEntryLabel + , cfgBlocks = Fold.toList (s^.gsBlocks) + } + +-- | Given the arguments, this returns the initial state, and an action for +-- computing the return value. +type FunctionDef ext t init ret m = + forall s . + Assignment (Atom s) init -> + (t s, Generator ext s t ret m (Expr ext s ret)) + +-- | The given @FunctionDef@ action is run to generate a registerized +-- CFG. The return value of @defineFunction@ is the generated CFG, +-- and a list of CFGs for any other auxiliary function definitions +-- generated along the way (e.g., for anonymous or inner functions). +-- +-- This is the same as @defineFunctionOpt@ with the identity +-- transformation. +defineFunction :: (Monad m, IsSyntaxExtension ext) + => Position -- ^ Source position for the function + -> Some (NonceGenerator m) -- ^ Nonce generator for internal use + -> FnHandle init ret -- ^ Handle for the generated function + -> FunctionDef ext t init ret m -- ^ Generator action and initial state + -> m (SomeCFG ext init ret, [AnyCFG ext]) -- ^ Generated CFG and inner function definitions +defineFunction p sng h f = defineFunctionOpt p sng h f (\_ cfg -> return cfg) + +-- | The main API for generating CFGs for a Crucible function. +-- +-- The given @FunctionDef@ action is run to generate a registerized +-- CFG. The return value of @defineFunction@ is the generated CFG, +-- and a list of CFGs for any other auxiliary function definitions +-- generated along the way (e.g., for anonymous or inner functions). +-- +-- The caller can supply a transformation to run over the generated CFG +-- (i.e. an optimization pass) +defineFunctionOpt :: (Monad m, IsSyntaxExtension ext) + => Position -- ^ Source position for the function + -> Some (NonceGenerator m) -- ^ Nonce generator for internal use + -> FnHandle init ret -- ^ Handle for the generated function + -> FunctionDef ext t init ret m -- ^ Generator action and initial state + -> (forall s. NonceGenerator m s + -> CFG ext s init ret + -> m (CFG ext s init ret)) -- ^ Transformation pass + -> m (SomeCFG ext init ret, [AnyCFG ext]) -- ^ Generated CFG and inner function definitions +defineFunctionOpt p sng h f optPass = seq h $ do + let argTypes = handleArgTypes h + Some ng <- return sng + inputs <- mkInputAtoms ng p argTypes + let inputSet = Set.fromList (toListFC (Some . AtomValue) inputs) + let (init_state, action) = f $! inputs + lbl <- Label <$> freshNonce ng + let cbs = initCurrentBlockState inputSet (LabelID lbl) + let ts = GS { _gsEntryLabel = lbl + , _gsBlocks = Seq.empty + , _gsNonceGen = ng + , _gsCurrent = cbs + , _gsPosition = p + , _gsState = init_state + , _seenFunctions = [] + } + ts' <- runGenerator (action >>= returnFromFunction) $! ts + g <- optPass ng (cfgFromGenerator h ts') + return (SomeCFG g, ts'^.seenFunctions) diff --git a/src/Lang/Crucible/CFG/Reg.hs b/src/Lang/Crucible/CFG/Reg.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/Reg.hs @@ -0,0 +1,1028 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.CFG.Reg +-- Description : Provides a representation of Crucible programs using +-- mutable registers rather than SSA. +-- Copyright : (c) Galois, Inc 2014-2016 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module defines CFGs that feature mutable registers, in +-- contrast to the Core CFGs ("Lang.Crucible.CFG.Core"), which are in +-- SSA form. Register CFGs can be translated into SSA CFGs using the +-- "Lang.Crucible.CFG.SSAConversion" module. +-- +-- Module "Lang.Crucible.CFG.Generator" provides a high-level monadic +-- interface for producing register CFGs. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Lang.Crucible.CFG.Reg + ( -- * CFG + CFG(..) + , cfgEntryBlock + , cfgInputTypes + , cfgArgTypes + , cfgReturnType + , substCFG + , SomeCFG(..) + , AnyCFG(..) + , Label(..) + , substLabel + , LambdaLabel(..) + , substLambdaLabel + , BlockID(..) + , substBlockID + , Reg(..) + , substReg + , traverseCFG + + -- * Atoms + , Atom(..) + , substAtom + , AtomSource(..) + , substAtomSource + , mkInputAtoms + , AtomValue(..) + , typeOfAtomValue + , substAtomValue + + -- * Values + , Value(..) + , typeOfValue + , substValue + , ValueSet + , substValueSet + + -- * Blocks + , Block + , mkBlock + , blockID + , blockStmts + , blockTerm + , blockExtraInputs + , blockKnownInputs + , blockAssignedValues + , substBlock + + -- * Statements + , Stmt(..) + , substStmt, substPosdStmt, mapStmtAtom + , TermStmt(..) + , termStmtInputs + , termNextLabels + , substTermStmt, substPosdTermStmt + , foldStmtInputs + + -- * Expressions + , Expr(..) + , exprType + , substExpr + + -- * Re-exports + , module Lang.Crucible.CFG.Common + ) where + +import qualified Data.Foldable as Fold +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Parameterized.Classes +import Data.Parameterized.Context as Ctx +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Word (Word64) +import Prettyprinter + +import What4.ProgramLoc +import What4.Symbol + +import Lang.Crucible.CFG.Common +import Lang.Crucible.CFG.Expr +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic (panic) +import Lang.Crucible.Syntax (IsExpr(..)) +import Lang.Crucible.Types + +-- | Print list of documents separated by commas and spaces. +commas :: [Doc ann] -> Doc ann +commas l = hcat (punctuate (comma <> pretty ' ') l) + +------------------------------------------------------------------------ +-- Label + +-- | A label for a block that does not expect an input. +newtype Label s = Label { labelId :: Nonce s UnitType } + +labelInt :: Label s -> Word64 +labelInt = indexValue . labelId + +instance Eq (Label s) where + Label i == Label j = i == j + +instance Ord (Label s) where + Label i `compare` Label j = i `compare` j + +instance Show (Label s) where + show (Label i) = '%' : show (indexValue i) + +instance Pretty (Label s) where + pretty (Label i) = pretty '%' <> pretty (indexValue i) + +substLabel :: Functor m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Label s + -> m (Label s') +substLabel f l = Label <$> f (labelId l) + +------------------------------------------------------------------------ +-- LambdaLabel + +-- | A label for a block that expects an argument of a specific type. +data LambdaLabel (s :: Type) (tp :: CrucibleType) + = LambdaLabel + { lambdaId :: !(Nonce s tp) + -- ^ Nonce that uniquely identifies this label within the CFG. + , lambdaAtom :: Atom s tp + -- ^ The atom to store the output result in. + -- + -- Note. This must be lazy to break a recursive cycle. + } + +lambdaInt :: LambdaLabel s tp -> Word64 +lambdaInt = indexValue . lambdaId + +instance Show (LambdaLabel s tp) where + show l = '%' : show (indexValue (lambdaId l)) + +instance Pretty (LambdaLabel s tp) where + pretty l = pretty '%' <> pretty (indexValue (lambdaId l)) + +substLambdaLabel :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> LambdaLabel s tp + -> m (LambdaLabel s' tp) +substLambdaLabel f ll = + LambdaLabel <$> f (lambdaId ll) <*> substAtom f (lambdaAtom ll) + +------------------------------------------------------------------------ +-- BlockID + +-- | A label for a block is either a standard label, or a label expecting an input. +data BlockID (s :: Type) where + LabelID :: Label s -> BlockID s + LambdaID :: LambdaLabel s tp -> BlockID s + +instance Show (BlockID s) where + show (LabelID l) = show l + show (LambdaID l) = show l + +instance Eq (BlockID s) where + LabelID x == LabelID y = x == y + LambdaID x == LambdaID y = isJust (testEquality x y) + _ == _ = False + +instance Ord (BlockID s) where + LabelID x `compare` LambdaID y = compare (labelInt x) (lambdaInt y) + LabelID x `compare` LabelID y = compare x y + LambdaID x `compare` LabelID y = compare (lambdaInt x) (labelInt y) + LambdaID x `compare` LambdaID y = compare (lambdaInt x) (lambdaInt y) + +substBlockID :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> BlockID s + -> m (BlockID s') +substBlockID f bid = + case bid of + LabelID l -> LabelID <$> substLabel f l + LambdaID ll -> LambdaID <$> substLambdaLabel f ll + +----------------------------------------------------------------------- +-- AtomSource + +-- | Identifies what generated an atom. +data AtomSource s (tp :: CrucibleType) + = Assigned + -- | Input argument to function. They are ordered before other + -- inputs to a program. + | FnInput + -- | Value passed into a lambda label. This must appear after + -- other expressions. + | LambdaArg !(LambdaLabel s tp) + +substAtomSource :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> AtomSource s tp + -> m (AtomSource s' tp) +substAtomSource f as = + case as of + Assigned -> pure Assigned + FnInput -> pure FnInput + LambdaArg ll -> LambdaArg <$> substLambdaLabel f ll + +------------------------------------------------------------------------ +-- Atom + +-- | An expression in the control flow graph with a unique identifier. +-- Unlike registers, atoms must be assigned exactly once. +data Atom s (tp :: CrucibleType) + = Atom { atomPosition :: !Position + -- ^ Position where register was declared (used for debugging). + , atomId :: !(Nonce s tp) + -- ^ Unique identifier for atom. + , atomSource :: !(AtomSource s tp) + -- ^ How the atom expression was defined. + , typeOfAtom :: !(TypeRepr tp) + } + +mkInputAtoms :: forall m s init + . Monad m + => NonceGenerator m s + -> Position + -> CtxRepr init + -> m (Assignment (Atom s) init) +mkInputAtoms ng p argTypes = Ctx.generateM (Ctx.size argTypes) f + where f :: Index init tp -> m (Atom s tp) + f i = do + n <- freshNonce ng + return $ + Atom { atomPosition = p + , atomId = n + , atomSource = FnInput + , typeOfAtom = argTypes Ctx.! i + } + +instance TestEquality (Atom s) where + testEquality x y = testEquality (atomId x) (atomId y) + +instance OrdF (Atom s) where + compareF x y = compareF (atomId x) (atomId y) + +instance Show (Atom s tp) where + show a = '$' : show (indexValue (atomId a)) + +instance Pretty (Atom s tp) where + pretty a = pretty '$' <> pretty (indexValue (atomId a)) + + +substAtom :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Atom s tp + -> m (Atom s' tp) +substAtom f a = + Atom <$> pure (atomPosition a) + <*> f (atomId a) + <*> substAtomSource f (atomSource a) + <*> pure (typeOfAtom a) + +------------------------------------------------------------------------ +-- Reg + +-- | A mutable value in the control flow graph. +data Reg s (tp :: CrucibleType) + = Reg { -- | Position where register was declared (used for debugging). + regPosition :: !Position + -- | Unique identifier for register. + , regId :: !(Nonce s tp) + -- | Type of register. + , typeOfReg :: !(TypeRepr tp) + } + +instance Pretty (Reg s tp) where + pretty r = pretty 'r' <> pretty (indexValue (regId r)) + +instance Show (Reg s tp) where + show r = 'r' : show (indexValue (regId r)) + +instance ShowF (Reg s) + +instance TestEquality (Reg s) where + testEquality x y = testEquality (regId x) (regId y) + +instance OrdF (Reg s) where + compareF x y = compareF (regId x) (regId y) + +substReg :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Reg s tp + -> m (Reg s' tp) +substReg f r = + Reg <$> pure (regPosition r) + <*> f (regId r) + <*> pure (typeOfReg r) + +------------------------------------------------------------------------ +-- Primitive operations + +instance TestEquality (LambdaLabel s) where + testEquality x y = testEquality (lambdaId x) (lambdaId y) + +instance OrdF (LambdaLabel s) where + compareF x y = compareF (lambdaId x) (lambdaId y) + +------------------------------------------------------------------------ +-- SomeValue and ValueSet + +-- | A value is either a register or an atom. +data Value s (tp :: CrucibleType) + = RegValue !(Reg s tp) + | AtomValue !(Atom s tp) + +instance TestEquality (Value s) where + testEquality (RegValue x) (RegValue y) = testEquality x y + testEquality (AtomValue x) (AtomValue y) = testEquality x y + testEquality _ _ = Nothing + +instance OrdF (Value s) where + compareF (RegValue x) (RegValue y) = compareF x y + compareF RegValue{} _ = LTF + compareF _ RegValue{} = GTF + compareF (AtomValue x) (AtomValue y) = compareF x y + +instance Pretty (Value s tp) where + pretty (RegValue r) = pretty r + pretty (AtomValue a) = pretty a + +instance Show (Value s tp) where + show (RegValue r) = show r + show (AtomValue a) = show a + +instance ShowF (Value s) + +typeOfValue :: Value s tp -> TypeRepr tp +typeOfValue (RegValue r) = typeOfReg r +typeOfValue (AtomValue a) = typeOfAtom a + +substValue :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Value s tp + -> m (Value s' tp) +substValue f v = + case v of + RegValue r -> RegValue <$> substReg f r + AtomValue a -> AtomValue <$> substAtom f a + +substValueAtom :: Applicative m + => (forall (x :: CrucibleType). Atom s x -> m (Atom s x)) + -> Value s tp + -> m (Value s tp) +substValueAtom f v = + case v of + RegValue r -> pure $ RegValue r + AtomValue a -> AtomValue <$> f a + +-- | A set of values. +type ValueSet s = Set (Some (Value s)) + +substValueSet :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> ValueSet s + -> m (ValueSet s') +substValueSet f vs = + Set.fromList <$> + traverse (\(Some v) -> Some <$> substValue f v) (Set.toList vs) + +------------------------------------------------------------------------ +-- Expr + +-- | An expression in RTL representation. +-- +-- The type arguments are: +-- +-- [@ext@] the extensions currently in use (use @()@ for no extension) +-- +-- [@s@] a dummy variable that should almost always be universally quantified +-- +-- [@tp@] the Crucible type of the expression +data Expr ext s (tp :: CrucibleType) + = App !(App ext (Expr ext s) tp) + -- ^ An application of an expression + | AtomExpr !(Atom s tp) + -- ^ An evaluated expession + +instance PrettyExt ext => Pretty (Expr ext s tp) where + pretty (App a) = ppApp pretty a + pretty (AtomExpr a) = pretty a + +instance PrettyExt ext => Show (Expr ext s tp) where + show e = show (pretty e) + +instance PrettyExt ext => ShowF (Expr ext s) + +instance TypeApp (ExprExtension ext) => IsExpr (Expr ext s) where + type ExprExt (Expr ext s) = ext + app = App + asApp (App x) = Just x + asApp _ = Nothing + + -- exprType :: Expr s tp -> TypeRepr tp + exprType (App a) = appType a + exprType (AtomExpr a) = typeOfAtom a + +instance IsString (Expr ext s (StringType Unicode)) where + fromString s = App (StringLit (fromString s)) + +substExpr :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Expr ext s tp + -> m (Expr ext s' tp) +substExpr f expr = + case expr of + App ap -> App <$> traverseFC (substExpr f) ap + AtomExpr a -> AtomExpr <$> substAtom f a + + +------------------------------------------------------------------------ +-- AtomValue + +-- | The value of an assigned atom. +data AtomValue ext s (tp :: CrucibleType) where + -- Evaluate an expression + EvalApp :: !(App ext (Atom s) tp) -> AtomValue ext s tp + -- Read a value from a register + ReadReg :: !(Reg s tp) -> AtomValue ext s tp + -- Evaluate an extension statement + EvalExt :: !(StmtExtension ext (Atom s) tp) -> AtomValue ext s tp + -- Read from a global vlalue + ReadGlobal :: !(GlobalVar tp) -> AtomValue ext s tp + -- Read from a reference cell + ReadRef :: !(Atom s (ReferenceType tp)) -> AtomValue ext s tp + -- Create a fresh reference cell + NewRef :: !(Atom s tp) -> AtomValue ext s (ReferenceType tp) + -- Create a fresh empty reference cell + NewEmptyRef :: !(TypeRepr tp) -> AtomValue ext s (ReferenceType tp) + -- Create a fresh uninterpreted constant of base type + FreshConstant :: !(BaseTypeRepr bt) -> !(Maybe SolverSymbol) -> AtomValue ext s (BaseToType bt) + -- Create a fresh uninterpreted constant of floating point type + FreshFloat :: !(FloatInfoRepr fi) -> !(Maybe SolverSymbol) -> AtomValue ext s (FloatType fi) + -- Create a fresh uninterpreted constant of natural number type + FreshNat :: !(Maybe SolverSymbol) -> AtomValue ext s NatType + + Call :: !(Atom s (FunctionHandleType args ret)) + -> !(Assignment (Atom s) args) + -> !(TypeRepr ret) + -> AtomValue ext s ret + +instance PrettyExt ext => Show (AtomValue ext s tp) where + show = show . pretty + +instance PrettyExt ext => Pretty (AtomValue ext s tp) where + pretty v = + case v of + EvalApp ap -> ppApp pretty ap + EvalExt st -> ppApp pretty st + ReadReg r -> pretty r + ReadGlobal g -> "global" <+> pretty g + ReadRef r -> "!" <> pretty r + NewRef a -> "newref" <+> pretty a + NewEmptyRef tp -> "emptyref" <+> pretty tp + -- TODO: replace viaShow once we have instance Pretty SolverSymbol + FreshConstant bt nm -> "fresh" <+> pretty bt <+> maybe mempty viaShow nm + FreshFloat fi nm -> "fresh" <+> pretty fi <+> maybe mempty viaShow nm + FreshNat nm -> "fresh nat" <+> maybe mempty viaShow nm + Call f args _ -> pretty f <> parens (commas (toListFC pretty args)) + +typeOfAtomValue :: (TypeApp (StmtExtension ext) , TypeApp (ExprExtension ext)) + => AtomValue ext s tp -> TypeRepr tp +typeOfAtomValue v = + case v of + EvalApp a -> appType a + EvalExt stmt -> appType stmt + ReadReg r -> typeOfReg r + ReadGlobal r -> globalType r + ReadRef r -> case typeOfAtom r of + ReferenceRepr tpr -> tpr + NewRef a -> ReferenceRepr (typeOfAtom a) + NewEmptyRef tp -> ReferenceRepr tp + FreshConstant bt _ -> baseToType bt + FreshFloat fi _ -> FloatRepr fi + FreshNat _ -> NatRepr + Call _ _ r -> r + +-- | Fold over all values in an 'AtomValue'. +foldAtomValueInputs :: TraverseExt ext + => (forall x . Value s x -> b -> b) + -> AtomValue ext s tp -> b -> b +foldAtomValueInputs f (ReadReg r) b = f (RegValue r) b +foldAtomValueInputs f (EvalExt stmt) b = foldrFC (f . AtomValue) b stmt +foldAtomValueInputs _ (ReadGlobal _) b = b +foldAtomValueInputs f (ReadRef r) b = f (AtomValue r) b +foldAtomValueInputs _ (NewEmptyRef _) b = b +foldAtomValueInputs f (NewRef a) b = f (AtomValue a) b +foldAtomValueInputs f (EvalApp app0) b = foldApp (f . AtomValue) b app0 +foldAtomValueInputs _ (FreshConstant _ _) b = b +foldAtomValueInputs _ (FreshFloat _ _) b = b +foldAtomValueInputs _ (FreshNat _) b = b +foldAtomValueInputs f (Call g a _) b = f (AtomValue g) (foldrFC' (f . AtomValue) b a) + +substAtomValue :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> AtomValue ext s tp + -> m (AtomValue ext s' tp) +substAtomValue f (ReadReg r) = ReadReg <$> substReg f r +substAtomValue f (EvalExt stmt) = EvalExt <$> traverseFC (substAtom f) stmt +substAtomValue _ (ReadGlobal g) = pure $ ReadGlobal g +substAtomValue f (ReadRef r) = ReadRef <$> substAtom f r +substAtomValue _ (NewEmptyRef tp) = pure $ NewEmptyRef tp +substAtomValue f (NewRef a) = NewRef <$> substAtom f a +substAtomValue f (EvalApp ap) = EvalApp <$> traverseFC (substAtom f) ap +substAtomValue _ (FreshConstant tp sym) = pure $ FreshConstant tp sym +substAtomValue _ (FreshFloat fi sym) = pure $ FreshFloat fi sym +substAtomValue _ (FreshNat sym) = pure $ FreshNat sym +substAtomValue f (Call g as ret) = Call <$> substAtom f g + <*> traverseFC (substAtom f) as + <*> pure ret + +mapAtomValueAtom :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Atom s x -> m (Atom s x)) + -> AtomValue ext s tp + -> m (AtomValue ext s tp) +mapAtomValueAtom _ (ReadReg r) = pure $ ReadReg r +mapAtomValueAtom f (EvalExt stmt) = EvalExt <$> traverseFC f stmt +mapAtomValueAtom _ (ReadGlobal g) = pure $ ReadGlobal g +mapAtomValueAtom f (ReadRef r) = ReadRef <$> f r +mapAtomValueAtom _ (NewEmptyRef tp) = pure $ NewEmptyRef tp +mapAtomValueAtom f (NewRef a) = NewRef <$> f a +mapAtomValueAtom f (EvalApp ap) = EvalApp <$> traverseFC f ap +mapAtomValueAtom _ (FreshConstant tp sym) = pure $ FreshConstant tp sym +mapAtomValueAtom _ (FreshFloat fi sym) = pure $ FreshFloat fi sym +mapAtomValueAtom _ (FreshNat sym) = pure $ FreshNat sym +mapAtomValueAtom f (Call g as ret) = Call <$> f g + <*> traverseFC f as + <*> pure ret + +ppAtomBinding :: PrettyExt ext => Atom s tp -> AtomValue ext s tp -> Doc ann +ppAtomBinding a v = pretty a <+> ":=" <+> pretty v + +------------------------------------------------------------------------ +-- Stmt + +-- | Statement in control flow graph. +data Stmt ext s + = forall tp . SetReg !(Reg s tp) !(Atom s tp) + | forall tp . WriteGlobal !(GlobalVar tp) !(Atom s tp) + | forall tp . WriteRef !(Atom s (ReferenceType tp)) !(Atom s tp) + | forall tp . DropRef !(Atom s (ReferenceType tp)) + | forall tp . DefineAtom !(Atom s tp) !(AtomValue ext s tp) + | Print !(Atom s (StringType Unicode)) + -- | Assert that the given expression is true. + | Assert !(Atom s BoolType) !(Atom s (StringType Unicode)) + -- | Assume the given expression. + | Assume !(Atom s BoolType) !(Atom s (StringType Unicode)) + | forall args . Breakpoint BreakpointName !(Assignment (Value s) args) + +instance PrettyExt ext => Show (Stmt ext s) where + show = show . pretty + +instance PrettyExt ext => Pretty (Stmt ext s) where + pretty s = + case s of + SetReg r e -> pretty r <+> ":=" <+> pretty e + WriteGlobal g r -> "global" <+> pretty g <+> ":=" <+> pretty r + WriteRef r v -> "ref" <+> pretty r <+> ":=" <+> pretty v + DropRef r -> "drop" <+> pretty r + DefineAtom a v -> ppAtomBinding a v + Print v -> "print" <+> pretty v + Assert c m -> "assert" <+> pretty c <+> pretty m + Assume c m -> "assume" <+> pretty c <+> pretty m + Breakpoint nm args -> "breakpoint" <+> pretty nm <+> parens (commas (toListFC pretty args)) + +-- | Return local value assigned by this statement or @Nothing@ if this +-- does not modify a register. +stmtAssignedValue :: Stmt ext s -> Maybe (Some (Value s)) +stmtAssignedValue s = + case s of + SetReg r _ -> Just (Some (RegValue r)) + DefineAtom a _ -> Just (Some (AtomValue a)) + WriteGlobal{} -> Nothing + WriteRef{} -> Nothing + DropRef{} -> Nothing + Print{} -> Nothing + Assert{} -> Nothing + Assume{} -> Nothing + Breakpoint{} -> Nothing + +-- | Fold all registers that are inputs tostmt. +foldStmtInputs :: TraverseExt ext => (forall x . Value s x -> b -> b) -> Stmt ext s -> b -> b +foldStmtInputs f s b = + case s of + SetReg _ e -> f (AtomValue e) b + WriteGlobal _ a -> f (AtomValue a) b + WriteRef r a -> f (AtomValue r) (f (AtomValue a) b) + DropRef r -> f (AtomValue r) b + DefineAtom _ v -> foldAtomValueInputs f v b + Print e -> f (AtomValue e) b + Assert c m -> f (AtomValue c) (f (AtomValue m) b) + Assume c m -> f (AtomValue c) (f (AtomValue m) b) + Breakpoint _ args -> foldrFC' f b args + +substStmt :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Stmt ext s + -> m (Stmt ext s') +substStmt f s = + case s of + SetReg r e -> SetReg <$> substReg f r <*> substAtom f e + WriteGlobal g a -> WriteGlobal <$> pure g <*> substAtom f a + WriteRef r a -> WriteRef <$> substAtom f r <*> substAtom f a + DropRef r -> DropRef <$> substAtom f r + DefineAtom a v -> DefineAtom <$> substAtom f a <*> substAtomValue f v + Print e -> Print <$> substAtom f e + Assert c m -> Assert <$> substAtom f c <*> substAtom f m + Assume c m -> Assume <$> substAtom f c <*> substAtom f m + Breakpoint nm args -> Breakpoint nm <$> traverseFC (substValue f) args + +mapStmtAtom :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Atom s x -> m (Atom s x)) + -> Stmt ext s + -> m (Stmt ext s) +mapStmtAtom f s = + case s of + SetReg r e -> SetReg r <$> f e + WriteGlobal g a -> WriteGlobal <$> pure g <*> f a + WriteRef r a -> WriteRef <$> f r <*> f a + DropRef r -> DropRef <$> f r + DefineAtom a v -> DefineAtom <$> f a <*> mapAtomValueAtom f v + Print e -> Print <$> f e + Assert c m -> Assert <$> f c <*> f m + Assume c m -> Assume <$> f c <*> f m + Breakpoint nm args -> Breakpoint nm <$> traverseFC (substValueAtom f) args + +substPosdStmt :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Posd (Stmt ext s) + -> m (Posd (Stmt ext s')) +substPosdStmt f s = + Posd <$> pure (pos s) <*> substStmt f (pos_val s) + +------------------------------------------------------------------------ +-- TermStmt + +-- | Statement that terminates a basic block in a control flow graph. +data TermStmt s (ret :: CrucibleType) where + -- Jump to the given block. + Jump :: !(Label s) + -> TermStmt s ret + -- Branch on condition. + Br :: !(Atom s BoolType) + -> !(Label s) + -> !(Label s) + -> TermStmt s ret + -- Switch on whether this is a maybe value. + MaybeBranch :: !(TypeRepr tp) + -> !(Atom s (MaybeType tp)) + -> !(LambdaLabel s tp) + -> !(Label s) + -> TermStmt s ret + + -- Switch on a variant value. Examine the tag of the variant + -- and jump to the appropriate switch target. + VariantElim :: !(CtxRepr varctx) + -> !(Atom s (VariantType varctx)) + -> !(Ctx.Assignment (LambdaLabel s) varctx) + -> TermStmt s ret + + -- Return from function. + Return :: !(Atom s ret) -> TermStmt s ret + + -- End block with a tail call. + TailCall :: !(Atom s (FunctionHandleType args ret)) + -> !(CtxRepr args) + -> !(Ctx.Assignment (Atom s) args) + -> TermStmt s ret + + -- Block ends because of a translation error. + ErrorStmt :: !(Atom s (StringType Unicode)) -> TermStmt s ret + + -- Jump to the given block, and provide it the + -- expression as input. + Output :: !(LambdaLabel s tp) + -> !(Atom s tp) + -> TermStmt s ret + +instance Show (TermStmt s ret) where + show = show . pretty + +instance Pretty (TermStmt s ret) where + pretty t0 = + case t0 of + Jump l -> "jump" <+> pretty l + Br c x y -> "branch" <+> pretty c <+> pretty x <+> pretty y + MaybeBranch _ c j n -> "switchMaybe" <+> pretty c <+> pretty j <+> pretty n + VariantElim _ e l -> + vcat + [ "switch" <+> pretty e <+> "{" + , indent 2 (vcat (ppSwitch pp l)) + , indent 2 "}" + ] + where pp nm v = pretty nm <> ":" <+> pretty v + Return e -> "return" <+> pretty e + TailCall f _ a -> "tail_call" <+> pretty f <> parens args + where args = commas (toListFC pretty a) + ErrorStmt e -> "error" <+> pretty e + Output l e -> "output" <+> pretty l <+> pretty e + + +ppSwitch :: forall tgt ctx ann. (forall (tp :: CrucibleType). String -> tgt tp -> Doc ann) -> Ctx.Assignment tgt ctx -> [Doc ann] +ppSwitch pp asgn = forIndex (Ctx.size asgn) f mempty + where f :: [Doc ann] -> Ctx.Index ctx (tp :: CrucibleType) -> [Doc ann] + f rs idx = rs Prelude.++ [ pp (show (Ctx.indexVal idx)) (asgn Ctx.! idx)] + +-- | Provide all registers in term stmt to fold function. +foldTermStmtAtoms :: (forall x . Atom s x -> b -> b) + -> TermStmt s ret + -> b + -> b +foldTermStmtAtoms f stmt0 b = + case stmt0 of + Jump _ -> b + Output _ e -> f e b + Br e _ _ -> f e b + MaybeBranch _ e _ _ -> f e b + VariantElim _ e _ -> f e b + Return e -> f e b + TailCall fn _ a -> f fn (foldrFC' f b a) + ErrorStmt e -> f e b + +substTermStmt :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> TermStmt s ret + -> m (TermStmt s' ret) +substTermStmt f stmt = + case stmt of + Jump l -> Jump <$> substLabel f l + Output ll a -> Output <$> substLambdaLabel f ll <*> substAtom f a + Br e c a -> Br <$> substAtom f e <*> substLabel f c <*> substLabel f a + MaybeBranch tp a ll l -> MaybeBranch <$> pure tp + <*> substAtom f a + <*> substLambdaLabel f ll + <*> substLabel f l + VariantElim ctx a lls -> VariantElim <$> pure ctx + <*> substAtom f a + <*> traverseFC (substLambdaLabel f) lls + Return e -> Return <$> substAtom f e + TailCall fn ctx args -> TailCall <$> substAtom f fn + <*> pure ctx + <*> traverseFC (substAtom f) args + ErrorStmt e -> ErrorStmt <$> substAtom f e + +substPosdTermStmt :: Applicative m + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Posd (TermStmt s ret) + -> m (Posd (TermStmt s' ret)) +substPosdTermStmt f posd + = Posd <$> pure (pos posd) <*> substTermStmt f (pos_val posd) + +-- | Returns the set of registers appearing as inputs to a terminal +-- statement. +termStmtInputs :: TermStmt s ret + -> ValueSet s +termStmtInputs stmt = foldTermStmtAtoms (Set.insert . Some . AtomValue) stmt Set.empty + + +-- | Returns the next labels for the given block. Error statements +-- have no next labels, while return/tail call statements return 'Nothing'. +termNextLabels :: TermStmt s ret + -> Maybe [BlockID s] +termNextLabels s0 = + case s0 of + Jump l -> Just [LabelID l] + Output l _ -> Just [LambdaID l] + Br _ x y -> Just [LabelID x, LabelID y] + MaybeBranch _ _ x y -> Just [LambdaID x, LabelID y] + VariantElim _ _ s -> Just $ toListFC LambdaID s + Return _ -> Nothing + TailCall{} -> Nothing + ErrorStmt _ -> Just [] + + +------------------------------------------------------------------------ +-- Block + +-- | A basic block within a function. +data Block ext s (ret :: CrucibleType) + = Block { blockID :: !(BlockID s) + , blockStmts :: !(Seq (Posd (Stmt ext s))) + , blockTerm :: !(Posd (TermStmt s ret)) + , blockExtraInputs :: !(ValueSet s) + -- | Registers that are known to be needed as inputs for this block. + -- For the first block, this includes the function arguments. + -- It also includes registers read by this block before they are + -- assigned. + -- It does not include the lambda reg for lambda blocks. + , blockKnownInputs :: !(ValueSet s) + -- | Registers assigned by statements in block. + -- This is a field so that its value can be memoized. + , blockAssignedValues :: !(ValueSet s) + } + +instance Eq (Block ext s ret) where + x == y = blockID x == blockID y + +instance Ord (Block ext s ret) where + compare x y = compare (blockID x) (blockID y) + +instance PrettyExt ext => Show (Block ext s ret) where + show = show . pretty + +instance Pretty (ValueSet s) where + pretty vs = commas (map (\(Some v) -> pretty v) (Set.toList vs)) + +instance PrettyExt ext => Pretty (Block ext s ret) where + pretty b = vcat [viaShow (blockID b), indent 2 stmts] + where stmts = vcat [ vcat (pretty . pos_val <$> Fold.toList (blockStmts b)) + , pretty (pos_val (blockTerm b)) ] + +mkBlock :: forall ext s ret + . TraverseExt ext + => BlockID s + -> ValueSet s -- ^ Extra inputs to block (only non-empty for initial block) + -> Seq (Posd (Stmt ext s)) + -> Posd (TermStmt s ret) + -> Block ext s ret +mkBlock block_id inputs stmts term = + Block { blockID = block_id + , blockStmts = stmts + , blockTerm = term + , blockExtraInputs = inputs + , blockAssignedValues = assigned_values + , blockKnownInputs = all_input_values + } + where inputs_with_lambda = + case block_id of + LabelID{} -> inputs + LambdaID l -> Set.insert (Some (AtomValue (lambdaAtom l))) inputs + + initState = (inputs_with_lambda, inputs) + + addUnassigned :: ValueSet s -> Value s x -> ValueSet s -> ValueSet s + addUnassigned ar r s + | Set.member (Some r) ar = s + | otherwise = Set.insert (Some r) s + + all_input_values + = foldTermStmtAtoms (addUnassigned assigned_values . AtomValue) + (pos_val term) + missing_values + + -- Function for inserting updating assigned regs, missing regs + -- with statement. + f :: (ValueSet s, ValueSet s) -> Posd (Stmt ext s) -> (ValueSet s, ValueSet s) + f (ar, mr) s = (ar', mr') + where ar' = case stmtAssignedValue (pos_val s) of + Nothing -> ar + Just r -> Set.insert r ar + mr' = foldStmtInputs (addUnassigned ar) (pos_val s) mr + + (assigned_values, missing_values) = Fold.foldl' f initState stmts + +substBlock :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> Block ext s ret + -> m (Block ext s' ret) +substBlock f b = + Block <$> substBlockID f (blockID b) + <*> traverse (substPosdStmt f) (blockStmts b) + <*> substPosdTermStmt f (blockTerm b) + <*> substValueSet f (blockExtraInputs b) + <*> substValueSet f (blockKnownInputs b) + <*> substValueSet f (blockAssignedValues b) + +------------------------------------------------------------------------ +-- CFG + +-- | A CFG using registers instead of SSA form. +-- +-- Parameter @ext@ is the syntax extension, @s@ is a phantom type +-- parameter identifying a particular CFG, @init@ is the list of input +-- types of the CFG, and @ret@ is the return type. +data CFG ext s (init :: Ctx CrucibleType) (ret :: CrucibleType) + = CFG { cfgHandle :: !(FnHandle init ret) + , cfgEntryLabel :: !(Label s) + , cfgBlocks :: ![Block ext s ret] + } + +cfgEntryBlock :: CFG ext s init ret -> Block ext s ret +cfgEntryBlock g = + fromMaybe + (error "Missing entry block") + (Fold.find (\b -> blockID b == LabelID (cfgEntryLabel g)) (cfgBlocks g)) + +cfgInputTypes :: CFG ext s init ret -> CtxRepr init +cfgInputTypes = cfgArgTypes +{-# DEPRECATED cfgInputTypes "Use cfgArgTypes instead" #-} + +cfgArgTypes :: CFG ext s init ret -> CtxRepr init +cfgArgTypes g = handleArgTypes (cfgHandle g) + +cfgReturnType :: CFG ext s init ret -> TypeRepr ret +cfgReturnType g = handleReturnType (cfgHandle g) + +-- | Rename all the atoms, labels, and other named things in the CFG. +-- Useful for rewriting, since the names can be generated from a nonce +-- generator the client controls (and can thus keep using to generate +-- fresh names). +substCFG :: ( Applicative m, TraverseExt ext ) + => (forall (x :: CrucibleType). Nonce s x -> m (Nonce s' x)) + -> CFG ext s init ret + -> m (CFG ext s' init ret) +substCFG f cfg = + CFG <$> pure (cfgHandle cfg) + <*> substLabel f (cfgEntryLabel cfg) + <*> traverse (substBlock f) (cfgBlocks cfg) + +-- | Run a computation along all of the paths in a cfg, without taking backedges. +-- +-- The computation has access to an environment that is specific to the current path +-- being explored, as well as a global environment that is maintained across the +-- entire computation. +traverseCFG :: ( Monad m, TraverseExt ext ) + => (genv -> penv -> Block ext s ret -> m (genv, penv)) + -> genv + -> penv + -> Block ext s ret + -> CFG ext s init ret + -> m genv +traverseCFG f genv0 penv0 b0 cfg = + traverseStep f bmap0 genv0 penv0 mempty b0 + where + bmap0 = Map.fromList [(blockID b, b) | b <- cfgBlocks cfg ] + +-- | Run a computation along all of the paths in a cfg, without taking backedges. +-- +-- The computation has access to an environment that is specific to the current path +-- being explored, as well as a global environment that is maintained across the +-- entire computation. +-- +-- Each step of the computation inspects the global- and +-- path-environments as well as the current block, and returns new +-- environments. +traverseStep :: forall m genv penv ext s ret. + Monad m + => (genv -> penv -> Block ext s ret -> m (genv, penv)) + -> Map.Map (BlockID s) (Block ext s ret) + -> genv + -> penv + -> Set.Set (BlockID s) + -> (Block ext s ret) + -> m genv +traverseStep f bmap genv penv seen blk + | blockID blk `Set.member` seen = + return genv + | otherwise = + do (genv', penv') <- f genv penv blk + Fold.foldlM (go penv' (Set.insert (blockID blk) seen)) genv' next + where + next = fromMaybe [] (termNextLabels (pos_val (blockTerm blk))) + + go penv' seen' genv' blkId + | Just blk' <- Map.lookup blkId bmap + = traverseStep f bmap genv' penv' seen' blk' + | otherwise + = panic "Reg.traverseStep" + [ "Block " ++ show blkId ++ " not found in block map" ] + + +instance PrettyExt ext => Show (CFG ext s init ret) where + show = show . pretty + +instance PrettyExt ext => Pretty (CFG ext s init ret) where + pretty g = do + let nm = viaShow (handleName (cfgHandle g)) + let args = + commas $ map (viewSome viaShow) $ Set.toList $ + blockExtraInputs (cfgEntryBlock g) + vcat [ pretty (cfgReturnType g) <+> nm <+> parens args + , vcat (pretty <$> cfgBlocks g) ] + +------------------------------------------------------------------------ +-- SomeCFG, AnyCFG + +-- | 'SomeCFG' is a CFG with an arbitrary parameter 's'. +data SomeCFG ext init ret = forall s . SomeCFG !(CFG ext s init ret) + +-- | Control flow graph. This data type closes existentially +-- over all the type parameters except @ext@. +data AnyCFG ext where + AnyCFG :: CFG ext blocks init ret + -> AnyCFG ext + +instance PrettyExt ext => Show (AnyCFG ext) where + show cfg = case cfg of AnyCFG c -> show c diff --git a/src/Lang/Crucible/CFG/SSAConversion.hs b/src/Lang/Crucible/CFG/SSAConversion.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/CFG/SSAConversion.hs @@ -0,0 +1,986 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.SSAConversion +-- Description : Allows converting from RTL to SSA representation. +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides a function for converting from the RTL to SSA +-- Crucible representation. +------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +module Lang.Crucible.CFG.SSAConversion + ( toSSA + ) where + +import Control.Exception (assert) +import Control.Lens ((&)) +import Control.Monad.State.Strict +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import qualified Data.Foldable as Fold +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, fromMaybe) +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Type.Equality +import qualified Prettyprinter as Pretty + +import What4.FunctionName (FunctionName) +import What4.ProgramLoc + +import Lang.Crucible.Analysis.Reachable +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Expr as C +import Lang.Crucible.CFG.Reg +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic (panic) + +#ifdef UNSAFE_OPS +-- We deliberately import Context.Unsafe as it is the only one that supports +-- the unsafe coerces between an index and its extension. +import Data.Parameterized.Context.Unsafe as Ctx (Assignment) +import Data.Parameterized.Context as Ctx hiding (Assignment) +import Data.Parameterized.Map (MapF) +import qualified Data.Parameterized.Map as MapF +import Unsafe.Coerce +#else +import Data.Parameterized.Context as Ctx +#endif + +------------------------------------------------------------------------ +-- Utilities + +-- | Given a list of pairs returns a map that maps each value appearing +-- in the first element to the second element in the set of pairs +-- containing it. +nextSetMap :: (Ord x, Ord y) => [(x,y)] -> Map x (Set y) +nextSetMap l = execState (traverse go l) Map.empty + where go (x,y) = modify $ Map.insertWith Set.union x (Set.singleton y) + +------------------------------------------------------------------------ +-- Input + +-- | An input is a wrapper around a value that also knows if the +-- value was obtained as the output from a previous block. +-- +-- * The first argument is true if the value was created from a previous block +-- * The second is the value itself. +data Input s + = Input { inputGeneratedPrev :: !Bool + -- ^ Stores true if the value was created from a previous block. + , inputValue :: !(Some (Value s)) + } + +instance Show (Input s) where + showsPrec p r = showsPrec p (inputValue r) + +instance Eq (Input s) where + x == y = inputValue x == inputValue y + +isOutputFromBlock :: BlockID s -> Some (Value s) -> Bool +isOutputFromBlock (LambdaID l) (Some (AtomValue a)) + | LambdaArg l' <- atomSource a = isJust (testEquality l l') +isOutputFromBlock _ _ = False + +mkInput :: BlockID s -> Some (Value s) -> Input s +mkInput b v = Input { inputGeneratedPrev = isOutputFromBlock b v + , inputValue = v + } + +instance Ord (Input s) where + -- LambdaArg introduced in this block should be last. + compare x y = + case (inputGeneratedPrev x, inputGeneratedPrev y) of + (True, True ) -> assert (inputValue x == inputValue y) EQ + (True, False) -> GT + (False, True ) -> LT + (False, False) -> compare (inputValue x) (inputValue y) + +------------------------------------------------------------------------ +-- BlockInput + +data BlockInput ext s blocks ret args + = BInput { binputID :: !(C.BlockID blocks args) + -- | Arguments expected by block. + , binputArgs :: !(Assignment (Value s) args) + , binputStmts :: !(Seq (Posd (Stmt ext s))) + , binputTerm :: !(Posd (ExtendedTermStmt s blocks ret)) + } + +-- The Breakpoint non-terminator statement becomes a jump during SSA conversion. +-- This datatype temporarily adds breakpoint as a terminator statement. +data ExtendedTermStmt s blocks ret where + BaseTermStmt :: TermStmt s ret -> ExtendedTermStmt s blocks ret + BreakStmt :: JumpInfo s blocks -> ExtendedTermStmt s blocks ret + +type BlockInputAssignment ext s blocks ret + = Assignment (BlockInput ext s blocks ret) + +extBlockInputAssignment :: + BlockInputAssignment ext s blocks ret a -> + BlockInputAssignment ext s (blocks ::> tp) ret a +extBlockInput :: + BlockInput ext s blocks ret args -> + BlockInput ext s (blocks ::> tp) ret arg +extBreakpoints :: + Bimap BreakpointName (Some (C.BlockID blocks)) -> + Bimap BreakpointName (Some (C.BlockID (blocks ::> tp))) +#ifdef UNSAFE_OPS +extBlockInputAssignment = unsafeCoerce + +extBlockInput = unsafeCoerce + +extBreakpoints = unsafeCoerce +#else +extBlockInputAssignment = fmapFC extBlockInput + +extBlockInput bi = bi { binputID = C.extendBlockID (binputID bi) } + +extBreakpoints = Bimap.mapR (mapSome C.extendBlockID) +#endif + +------------------------------------------------------------------------ +-- inferRegAssignment + +inferRegAssignment :: Set (Input s) + -> Some (Assignment (Value s)) +inferRegAssignment s = Ctx.fromList (inputValue <$> Set.toList s) + +------------------------------------------------------------------------ +-- JumpInfo + +data JumpInfo s blocks where + JumpInfo :: C.BlockID blocks types + -> C.CtxRepr types + -> Assignment (Value s) types + -> JumpInfo s blocks + + +emptyJumpInfoMap :: JumpInfoMap s blocks +lookupJumpInfo :: Label s -> JumpInfoMap s blocks -> Maybe (JumpInfo s blocks) +insertJumpInfo :: Label s -> JumpInfo s blocks -> JumpInfoMap s blocks -> JumpInfoMap s blocks + +#ifdef UNSAFE_OPS +type JumpInfoMap s blocks = Map (Label s) (JumpInfo s blocks) + +extJumpInfoMap :: JumpInfoMap s blocks -> JumpInfoMap s (blocks ::> args) +extJumpInfoMap = unsafeCoerce + + +emptyJumpInfoMap = Map.empty +lookupJumpInfo = Map.lookup +insertJumpInfo = Map.insert + +#else +data JumpInfoMap s blocks + = forall blocks'. + JumpInfoMap + { _jimDiff :: !(Diff blocks' blocks) + , _jimMap :: !(Map (Label s) (JumpInfo s blocks')) + , _jimThunk :: Map (Label s) (JumpInfo s blocks) -- NB! don't make this strict + } + +emptyJumpInfoMap = JumpInfoMap noDiff Map.empty Map.empty + +extJumpInfoMap :: JumpInfoMap s blocks -> JumpInfoMap s (blocks ::> args) +extJumpInfoMap (JumpInfoMap diff mp _) = + let diff' = extendRight diff + in JumpInfoMap diff' mp (fmap (extJumpInfo diff') mp) + +lookupJumpInfo l (JumpInfoMap diff mp _) = fmap (extJumpInfo diff) (Map.lookup l mp) +--lookupJumpInfo l mp = Map.lookup l (jimThunk mp) + +insertJumpInfo l ji (JumpInfoMap _ _ thk) = + let mp = Map.insert l ji thk + in JumpInfoMap noDiff mp mp + +-- | Extend jump target +extJumpInfo :: Diff blocks' blocks -> JumpInfo s blocks' -> JumpInfo s blocks +extJumpInfo diff (JumpInfo b typs a) = JumpInfo (C.extendBlockID' diff b) typs a +#endif + + +------------------------------------------------------------------------ +-- SwitchInfo + +data SwitchInfo s blocks tp where + SwitchInfo :: C.BlockID blocks (args ::> tp) + -> C.CtxRepr args + -> Assignment (Value s) args + -> SwitchInfo s blocks tp + +emptySwitchInfoMap :: SwitchInfoMap s blocks + +insertSwitchInfo :: LambdaLabel s tp + -> SwitchInfo s blocks tp + -> SwitchInfoMap s blocks + -> SwitchInfoMap s blocks +lookupSwitchInfo :: LambdaLabel s tp -> SwitchInfoMap s blocks -> Maybe (SwitchInfo s blocks tp) + +#ifdef UNSAFE_OPS +{- +instance CoercibleF (SwitchInfo s blocks) where + coerceF x = Data.Coerce.coerce x +-} + +newtype SwitchInfoMap s blocks = SwitchInfoMap (MapF (LambdaLabel s) (SwitchInfo s blocks)) + +emptySwitchInfoMap = SwitchInfoMap MapF.empty + +extSwitchInfoMap :: SwitchInfoMap s blocks + -> SwitchInfoMap s (blocks ::> args) +extSwitchInfoMap = unsafeCoerce + +insertSwitchInfo l si (SwitchInfoMap m) = SwitchInfoMap (MapF.insert l si m) +lookupSwitchInfo l (SwitchInfoMap m) = MapF.lookup l m + +#else +newtype SwitchInfoMap s blocks = + SwitchInfoMap (Map (Some (LambdaLabel s)) (SomeSwitchInfo s blocks)) +data SomeSwitchInfo s blocks = forall tp. SomeSwitchInfo (C.TypeRepr tp) (SwitchInfo s blocks tp) + +mapSomeSI :: (forall tp. SwitchInfo s b tp -> SwitchInfo s b' tp) -> SomeSwitchInfo s b -> SomeSwitchInfo s b' +mapSomeSI f (SomeSwitchInfo tp si) = SomeSwitchInfo tp (f si) + +emptySwitchInfoMap = SwitchInfoMap Map.empty + +extSwitchInfoMap :: SwitchInfoMap s blocks + -> SwitchInfoMap s (blocks ::> args) +extSwitchInfoMap (SwitchInfoMap m) = + SwitchInfoMap $ fmap (mapSomeSI extSwitchInfo) m + +insertSwitchInfo l si (SwitchInfoMap m) = + SwitchInfoMap $ Map.insert (Some l) (SomeSwitchInfo (typeOfAtom (lambdaAtom l)) si) m + +lookupSwitchInfo l (SwitchInfoMap m) = + case Map.lookup (Some l) m of + Nothing -> Nothing + Just (SomeSwitchInfo tr si) -> Just $ + case testEquality tr (typeOfAtom (lambdaAtom l)) of + Just Refl -> si + Nothing -> error "Lang.Crucible.SSAConversion.lookupSwitchInfo: type mismatch!" + +-- | Extend switch target +extSwitchInfo :: SwitchInfo s blocks tp -> SwitchInfo s (blocks::>args) tp +extSwitchInfo (SwitchInfo b typs a) = SwitchInfo (C.extendBlockID b) typs a +#endif + +extBlockInfo :: + BlockInfo ext s ret blocks -> + BlockInput ext s (blocks ::> args) ret args -> + BlockInfo ext s ret (blocks ::> args) +extBlockInfo bi binput = do + let blocks' = extBlockInputAssignment $ biBlocks bi + let jump_info' = extJumpInfoMap $ biJumpInfo bi + let switch_info' = extSwitchInfoMap $ biSwitchInfo bi + let breakpoints' = extBreakpoints $ biBreakpoints bi + BI { biBlocks = extend blocks' binput + , biJumpInfo = jump_info' + , biSwitchInfo = switch_info' + , biBreakpoints = breakpoints' + } + +------------------------------------------------------------------------ +-- PredMap + +newtype PredMap ext s ret = PredMap (Map (BlockID s) [Block ext s ret]) + +instance Show (PredMap ext s ret) where + show (PredMap m) = show (fmap blockID <$> m) + +-- | Return labels that may jump to given label. +getPredecessorLabels :: BlockID s -> PredMap ext s ret -> [Block ext s ret] +getPredecessorLabels l (PredMap m) = fromMaybe [] (Map.lookup l m) + +-- | Maps each block to the set of blocks that jump to it. +blockPredMap :: [Block ext s ret] -> PredMap ext s ret +blockPredMap l = PredMap (Set.toList <$> nextSetMap pairs) + where pairs = [ (n, b) + | b <- l + , n <- fromMaybe [] (termNextLabels (pos_val (blockTerm b))) + ] + +------------------------------------------------------------------------ +-- BlockInputMap + +type BlockInputMap s = Map (BlockID s) (Set (Input s)) + +-- | Return inputs expected by block. +inputsForBlock :: Block ext s ret + -> Set (Input s) +inputsForBlock b = Set.map (mkInput (blockID b)) (blockKnownInputs b) + +-- | Define map that maps labels to the set of registers they need. +initialInputMap :: [Block ext s ret] -> BlockInputMap s +initialInputMap blocks = Map.fromList $ + [ (blockID b, inputsForBlock b) + | b <- blocks + ] + +-- | Return map that stores arguments needed by each block. +completeInputs :: forall ext s ret . [Block ext s ret] -> BlockInputMap s +completeInputs blocks = do + let block_map = Map.fromList [ (blockID b, b) | b <- blocks ] + -- pred_map maps each label to its predecessors. + let pred_map = blockPredMap blocks + let go :: Set (BlockID s) -- Set of blocks to revisit. + -> BlockInputMap s + -- Map from block labels to arguments corresponding block needs at end. + -> BlockInputMap s + go s0 input_map = + case Set.maxView s0 of + Nothing -> input_map + Just (next_label, rest_labels) -> do + let inputs = case Map.lookup next_label input_map of + Just i -> i + Nothing -> panic "Crucible.CFG.SSAConversion" + [ "Unable to get label from input map" ] + + let resolve_pred :: [Block ext s ret] + -> Set (BlockID s) + -> BlockInputMap s + -> BlockInputMap s + resolve_pred [] s m = go s m + resolve_pred (prev_block:r) s m = do + let prev_label = blockID prev_block + -- Get list of inputs already computed for block. + let prev_inputs = case Map.lookup prev_label m of + Just previ -> previ + Nothing -> panic "Crucible.CFG.SSAConversion" + [ "Unable to get prev_label from input map" ] + -- Compute the inputs needed at the start of prev_block + let new_inputs = Set.map (mkInput (blockID prev_block)) + $ (`Set.difference` blockAssignedValues prev_block) + $ Set.map inputValue inputs + let all_inputs = Set.union prev_inputs new_inputs + if Set.isSubsetOf new_inputs prev_inputs then + resolve_pred r s m + else do + let m' = Map.insert prev_label all_inputs m + resolve_pred r (Set.insert prev_label s) m' + let prev_blocks = getPredecessorLabels next_label pred_map + resolve_pred prev_blocks rest_labels input_map + -- Compute arguments to each block. + go (Map.keysSet block_map) (initialInputMap blocks) + +------------------------------------------------------------------------ +-- Infer information about SSA. + +-- | Information that is statically inferred from the block structure. +data BlockInfo ext s ret blocks + = BI { biBlocks :: !(Assignment (BlockInput ext s blocks ret) blocks) + , biJumpInfo :: !(JumpInfoMap s blocks) + , biSwitchInfo :: !(SwitchInfoMap s blocks) + , biBreakpoints :: !(Bimap BreakpointName (Some (C.BlockID blocks))) + } + +-- | This infers the information given a set of blocks. +inferBlockInfo :: forall ext s ret . [Block ext s ret] -> Some (BlockInfo ext s ret) +inferBlockInfo blocks = seq input_map $ resolveBlocks bi0 blocks + where input_map = completeInputs blocks + bi0 = BI { biBlocks = empty + , biJumpInfo = emptyJumpInfoMap + , biSwitchInfo = emptySwitchInfoMap + , biBreakpoints = Bimap.empty + } + resolveBlocks :: + BlockInfo ext s ret blocks -> + [Block ext s ret] -> + Some (BlockInfo ext s ret) + resolveBlocks bi [] = Some bi + resolveBlocks bi (b:rest) = do + let sz = size (biBlocks bi) + let untyped_id = blockID b + let inputs = case Map.lookup untyped_id input_map of + Just i -> i + Nothing -> panic "Crucible.CFG.SSAConversion.inferBlockInfo" + [ "Unable to get untyped_id from input map" ] + case inferRegAssignment inputs of + Some ra -> do + let crepr = fmapFC typeOfValue ra + case untyped_id of + LabelID l -> do + let block_id = C.BlockID (nextIndex sz) + let block_term = (blockTerm b) { pos_val = BaseTermStmt $ pos_val $ blockTerm b } + let binput = BInput { binputID = block_id + , binputArgs = ra + , binputStmts = blockStmts b + , binputTerm = block_term + } + let bi' = extBlockInfo bi binput + let ji = JumpInfo block_id crepr ra + let bi'' = bi' { biJumpInfo = insertJumpInfo l ji (biJumpInfo bi') } + splitLastBlockInputOnBreakpoints bi'' rest + LambdaID l -> do + let block_id = C.BlockID (nextIndex sz) + let lastArg = AtomValue (lambdaAtom l) + let block_term = (blockTerm b) { pos_val = BaseTermStmt $ pos_val $ blockTerm b } + let binput = BInput { binputID = block_id + , binputArgs = ra :> lastArg + , binputStmts = blockStmts b + , binputTerm = block_term + } + let bi' = extBlockInfo bi binput + let si = SwitchInfo block_id crepr ra + let bi'' = bi' { biSwitchInfo = insertSwitchInfo l si (biSwitchInfo bi') } + splitLastBlockInputOnBreakpoints bi'' rest + splitLastBlockInputOnBreakpoints :: + BlockInfo ext s ret blocks -> + [Block ext s ret] -> + Some (BlockInfo ext s ret) + splitLastBlockInputOnBreakpoints bi rest + | first_binputs :> last_binput <- biBlocks bi + , (first_stmts, break_stmt Seq.:<| last_stmts) <- + Seq.breakl isBreakpoint (binputStmts last_binput) + , Breakpoint nm args <- pos_val break_stmt = do + let block_id = C.BlockID $ nextIndex $ size $ biBlocks bi + + let first_binputs' = extBlockInputAssignment $ first_binputs + + let jump_info = JumpInfo block_id (fmapFC typeOfValue args) args + let last_binput' = (extBlockInput last_binput) + { binputStmts = first_stmts + , binputTerm = break_stmt { pos_val = BreakStmt jump_info } + } + + let new_binput = (extBlockInput last_binput) + { binputID = block_id + , binputArgs = args + , binputStmts = last_stmts + } + + let new_breakpoints = do + let try_new_breakpoints = Bimap.tryInsert nm (Some block_id) $ + extBreakpoints $ biBreakpoints bi + if Bimap.pairMember (nm, (Some block_id)) try_new_breakpoints + then try_new_breakpoints + else error $ "Duplicate breakpoint: " ++ show nm + let bi' = BI + { biBlocks = first_binputs' :> last_binput' :> new_binput + , biJumpInfo = extJumpInfoMap $ biJumpInfo bi + , biSwitchInfo = extSwitchInfoMap $ biSwitchInfo bi + , biBreakpoints = new_breakpoints + } + splitLastBlockInputOnBreakpoints bi' rest + splitLastBlockInputOnBreakpoints bi rest = resolveBlocks bi rest + isBreakpoint :: Posd (Stmt ext s) -> Bool + isBreakpoint = \case + Posd _ Breakpoint{} -> True + _ -> False + + +------------------------------------------------------------------------ +-- Translates from RTL with inference information to SSA. + +data MaybeF f tp where + JustF :: f tp -> MaybeF f tp + NothingF :: MaybeF f tp + +-- | Map each core SSA binding to the expression that generated it if it +-- was generated by an expression. +type RegExprs ext ctx = Assignment (MaybeF (C.Expr ext ctx)) ctx + +#ifdef UNSAFE_OPS + +extendRegExprs :: MaybeF (C.Expr ext ctx) tp -> RegExprs ext ctx -> RegExprs ext (ctx ::> tp) +extendRegExprs r e = unsafeCoerce (e :> r) + +-- | Maps values in mutable representation to the current value in the SSA form. +newtype TypedRegMap s ctx = TypedRegMap { _typedRegMap :: MapF (Value s) (C.Reg ctx) } + +-- | Resolve a register +resolveReg :: TypedRegMap s ctx -> Value s tp -> C.Reg ctx tp +resolveReg (TypedRegMap m) r = fromMaybe (error msg) (MapF.lookup r m) + where msg = "Cannot find (unsafe) reg value " ++ show r ++ " " + ++ "in TypedRegMap: " ++ (show m) + +-- | Resolve an atom +resolveAtom :: TypedRegMap s ctx -> Atom s tp -> C.Reg ctx tp +resolveAtom (TypedRegMap m) r = fromMaybe (error msg) (MapF.lookup (AtomValue r) m) + where msg = "Cannot find (unsafe) atom value " ++ show r ++ "." + +regMapFromAssignment :: forall s args + . Assignment (Value s) args + -> TypedRegMap s args +regMapFromAssignment a = TypedRegMap $ forIndex (size a) go MapF.empty + where go :: MapF (Value s) (C.Reg args) + -> Index args tp + -> MapF (Value s) (C.Reg args) + go m i = MapF.insert (a ! i) (C.Reg i) m + +extendRegMap :: TypedRegMap s ctx + -> TypedRegMap s (ctx ::> tp) +extendRegMap = unsafeCoerce + +-- | Assign existing register to atom in typed RegMap. +bindValueReg + :: Value s tp + -> C.Reg ctx tp + -> TypedRegMap s ctx + -> TypedRegMap s ctx +bindValueReg r cr (TypedRegMap m) = TypedRegMap $ MapF.insert r cr m + +#else + +extendRegExprs :: MaybeF (C.Expr ext ctx) tp -> RegExprs ext ctx -> RegExprs ext (ctx ::> tp) +extendRegExprs r e = fmapFC ext e :> ext r + where ext :: MaybeF (C.Expr ctx) tp' -> MaybeF (C.Expr (ctx ::> tp)) tp' + ext NothingF = NothingF + ext (JustF (C.App app)) = JustF (C.App (C.mapApp C.extendReg app)) + +data SomeReg ctx where + SomeReg :: C.TypeRepr tp -> C.Reg ctx tp -> SomeReg ctx + +newtype TypedRegMap s ctx = TypedRegMap { _typedRegMap :: Map (Some (Value s)) (SomeReg ctx) } + +-- | Resolve a register +resolveReg :: TypedRegMap s ctx -> Value s tp -> C.Reg ctx tp +resolveReg (TypedRegMap m) r = creg + where creg = case Map.lookup (Some r) m of + Nothing -> error msg + Just (SomeReg tr r') -> + case testEquality tr (typeOfValue r) of + Nothing -> error msg + Just Refl -> r' + + msg = "Cannot find (safe) reg value " ++ show r + +-- | Resolve an atom +resolveAtom :: TypedRegMap s ctx -> Atom s tp -> C.Reg ctx tp +resolveAtom m a = resolveReg m (AtomValue a) + +regMapFromAssignment :: forall s args + . Assignment (Value s) args + -> TypedRegMap s args +regMapFromAssignment a = TypedRegMap $ forIndex (size a) go Map.empty + where go :: Map (Some (Value s)) (SomeReg args) + -> Index args tp + -> Map (Some (Value s)) (SomeReg args) + go m i = + let r = a ! i + in Map.insert (Some r) (SomeReg (typeOfValue r) (C.Reg i)) m + +extendRegMap :: TypedRegMap s ctx + -> TypedRegMap s (ctx ::> tp) +extendRegMap (TypedRegMap m) = + TypedRegMap $ fmap (\(SomeReg tr x) -> SomeReg tr (C.extendReg x)) m + +-- | Assign existing register to atom in typed RegMap. +bindValueReg + :: Value s tp + -> C.Reg ctx tp + -> TypedRegMap s ctx + -> TypedRegMap s ctx +bindValueReg r cr (TypedRegMap m) = + TypedRegMap $ Map.insert (Some r) (SomeReg (typeOfValue r) cr) m + +#endif + +-- | Assign new register to value in typed reg map. +assignRegister + :: Value s tp + -> Size ctx + -> TypedRegMap s ctx + -> TypedRegMap s (ctx ::> tp) +assignRegister r sz m = + bindValueReg r (C.Reg (nextIndex sz)) (extendRegMap m) + +copyValue + :: Value s tp -- ^ Assign + -> Value s tp + -> TypedRegMap s ctx + -> TypedRegMap s ctx +copyValue r r' m = bindValueReg r (resolveReg m r') m + + +resolveJumpTarget :: BlockInfo ext s ret blocks + -> TypedRegMap s ctx + -> Label s + -> C.JumpTarget blocks ctx +resolveJumpTarget bi reg_map next_lbl = do + case lookupJumpInfo next_lbl (biJumpInfo bi) of + Nothing -> error "Could not find label in resolveJumpTarget" + Just (JumpInfo next_id types inputs) -> do + let args = fmapFC (resolveReg reg_map) inputs + C.JumpTarget next_id types args + +-- | Resolve a lambda label into a typed jump target. +resolveLambdaAsJump :: BlockInfo ext s ret blocks + -> TypedRegMap s ctx + -> LambdaLabel s tp + -> C.Reg ctx tp + -> C.JumpTarget blocks ctx +resolveLambdaAsJump bi reg_map next_lbl output = + case lookupSwitchInfo next_lbl (biSwitchInfo bi) of + Nothing -> error "Could not find label in resolveLambdaAsJump" + Just (SwitchInfo block_id types inputs) -> do + let types' = types :> typeOfAtom (lambdaAtom next_lbl) + let args = fmapFC (resolveReg reg_map) inputs + let args' = args `extend` output + C.JumpTarget block_id types' args' + +-- | Resolve a lambda label into a typed switch target. +resolveLambdaAsSwitch :: BlockInfo ext s ret blocks + -> TypedRegMap s ctx + -> LambdaLabel s tp + -> C.SwitchTarget blocks ctx tp +resolveLambdaAsSwitch bi reg_map next_lbl = + case lookupSwitchInfo next_lbl (biSwitchInfo bi) of + Nothing -> error "Could not find label in resolveLambdaAsSwitch" + Just (SwitchInfo block_id types inputs) -> do + let args = fmapFC (resolveReg reg_map) inputs + C.SwitchTarget block_id types args + +-- | Resolve an untyped terminal statement to a typed one. +resolveTermStmt :: BlockInfo ext s ret blocks + -> TypedRegMap s ctx + -> RegExprs ext ctx + -- ^ Maps registers to associated expressions. + -> ExtendedTermStmt s blocks ret + -> C.TermStmt blocks ret ctx +resolveTermStmt bi reg_map bindings (BaseTermStmt t0) = + case t0 of + Jump l -> C.Jump (resolveJumpTarget bi reg_map l) + + Br c x y -> do + let c_r = resolveAtom reg_map c + case bindings ! C.regIndex c_r of + JustF (C.App (C.BoolLit True)) -> C.Jump (resolveJumpTarget bi reg_map x) + JustF (C.App (C.BoolLit False)) -> C.Jump (resolveJumpTarget bi reg_map y) + _ -> C.Br c_r + (resolveJumpTarget bi reg_map x) + (resolveJumpTarget bi reg_map y) + MaybeBranch tp e j n -> do + let e_r = resolveAtom reg_map e + case bindings ! C.regIndex e_r of + JustF (C.App (C.JustValue _ je)) -> C.Jump (resolveLambdaAsJump bi reg_map j je) + JustF (C.App (C.NothingValue _)) -> C.Jump (resolveJumpTarget bi reg_map n) + _ -> C.MaybeBranch tp + e_r + (resolveLambdaAsSwitch bi reg_map j) + (resolveJumpTarget bi reg_map n) + + VariantElim ctx e s -> do + let e_r = resolveAtom reg_map e + case bindings ! C.regIndex e_r of + JustF (C.App (C.InjectVariant _ idx x)) -> + C.Jump (resolveLambdaAsJump bi reg_map (s Ctx.! idx) x) + _ -> C.VariantElim ctx e_r (fmapFC (resolveLambdaAsSwitch bi reg_map) s) + + Return e -> C.Return (resolveAtom reg_map e) + TailCall f ctx args -> do + C.TailCall (resolveAtom reg_map f) ctx (fmapFC (resolveAtom reg_map) args) + ErrorStmt e -> C.ErrorStmt (resolveAtom reg_map e) + + Output l e -> C.Jump (resolveLambdaAsJump bi reg_map l (resolveAtom reg_map e)) +resolveTermStmt _ reg_map _ (BreakStmt (JumpInfo next_id types inputs)) = do + let args = fmapFC (resolveReg reg_map) inputs + C.Jump $ C.JumpTarget next_id types args + +#ifdef UNSAFE_OPS +type AppRegMap ext ctx = MapF (C.App ext (C.Reg ctx)) (C.Reg ctx) + +appRegMap_extend :: AppRegMap ext ctx -> AppRegMap ext (ctx ::> tp) +appRegMap_extend = unsafeCoerce + +appRegMap_insert :: ( TraversableFC (C.ExprExtension ext) + , OrdFC (C.ExprExtension ext) + ) + => C.App ext (C.Reg ctx) tp + -> C.Reg (ctx ::> tp) tp + -> AppRegMap ext ctx + -> AppRegMap ext (ctx ::> tp) +appRegMap_insert k v m = MapF.insert (fmapFC C.extendReg k) v (appRegMap_extend m) + +appRegMap_lookup :: ( OrdFC (C.ExprExtension ext) + ) + => C.App ext (C.Reg ctx) tp + -> AppRegMap ext ctx + -> Maybe (C.Reg ctx tp) +appRegMap_lookup = MapF.lookup + +appRegMap_empty :: AppRegMap ext ctx +appRegMap_empty = MapF.empty +#else +type AppRegMap ext ctx = Map (Some (C.App ext (C.Reg ctx))) (SomeReg ctx) + +appRegMap_extend :: AppRegMap ext ctx -> AppRegMap ext (ctx ::> tp) +appRegMap_extend = Map.fromList . fmap f . Map.toList + where f (Some app, SomeReg tp reg) = (Some (C.mapApp C.extendReg app), SomeReg tp (C.extendReg reg)) + +appRegMap_insert :: OrdFC (C.ExprExtension ext) + => C.App ext (C.Reg ctx) tp + -> C.Reg (ctx::>tp) tp + -> AppRegMap ext ctx + -> AppRegMap ext (ctx ::> tp) +appRegMap_insert k v m = + Map.insert (Some (C.mapApp C.extendReg k)) (SomeReg (C.appType k) v) (appRegMap_extend m) + +appRegMap_lookup :: C.App ext (C.Reg ctx) tp + -> AppRegMap ext ctx + -> Maybe (C.Reg ctx tp) +appRegMap_lookup app m = + case Map.lookup (Some app) m of + Nothing -> Nothing + Just (SomeReg tp r) + | Just Refl <- testEquality tp (C.appType app) -> Just r + _ -> error "appRegMap_lookup: impossible!" + + +appRegMap_empty :: AppRegMap ext ctx +appRegMap_empty = Map.empty + +#endif + +-- | Resolve a list of statements to a typed list. +resolveStmts :: C.IsSyntaxExtension ext + => FunctionName + -> BlockInfo ext s ret blocks + -> Size ctx + -> TypedRegMap s ctx + -> RegExprs ext ctx + -- ^ Maps registers back to the expression that generated them (if any) + -> AppRegMap ext ctx + -- ^ Maps applications to register that stores their value. + -- Used to eliminate redundant operations. + -> [Posd (Stmt ext s)] + -> Posd (ExtendedTermStmt s blocks ret) + -> C.StmtSeq ext blocks ret ctx +resolveStmts nm bi _ reg_map bindings _ [] (Posd p t) = do + C.TermStmt (mkProgramLoc nm p) + (resolveTermStmt bi reg_map bindings t) +resolveStmts nm bi sz reg_map bindings appMap (Posd p s0:rest) t = do + let pl = mkProgramLoc nm p + case s0 of + SetReg r a -> do + let reg_map' = reg_map & copyValue (RegValue r) (AtomValue a) + resolveStmts nm bi sz reg_map' bindings appMap rest t + WriteGlobal v a -> do + C.ConsStmt pl + (C.WriteGlobal v (resolveAtom reg_map a)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + WriteRef r a -> do + C.ConsStmt pl + (C.WriteRefCell (resolveAtom reg_map r) (resolveAtom reg_map a)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + DropRef r -> do + C.ConsStmt pl + (C.DropRefCell (resolveAtom reg_map r)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + DefineAtom a av -> do + case av of + ReadReg r -> do + let reg_map' = reg_map & copyValue (AtomValue a) (RegValue r) + resolveStmts nm bi sz reg_map' bindings appMap rest t + EvalExt estmt -> do + let estmt' = fmapFC (resolveAtom reg_map) estmt + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + -- No expression to associate with this value. + let bindings' = bindings & extendRegExprs NothingF + -- No App to memoize in this case. + let appMap' = appMap & appRegMap_extend + C.ConsStmt pl + (C.ExtendAssign estmt') + (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + ReadGlobal v -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + -- No expression to associate with this value. + let bindings' = bindings & extendRegExprs NothingF + -- No App to memoize in this case. + let appMap' = appMap & appRegMap_extend + C.ConsStmt pl + (C.ReadGlobal v) + (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + NewRef v -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + -- No expression to associate with this value. + let bindings' = bindings & extendRegExprs NothingF + -- No App to memoize in this case. + let appMap' = appMap & appRegMap_extend + -- Resolve the atom + let v' = resolveAtom reg_map v + C.ConsStmt pl + (C.NewRefCell (typeOfAtom v) v') + (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + NewEmptyRef tp -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + -- No expression to associate with this value. + let bindings' = bindings & extendRegExprs NothingF + -- No App to memoize in this case. + let appMap' = appMap & appRegMap_extend + -- Resolve the atom + C.ConsStmt pl + (C.NewEmptyRefCell tp) + (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + ReadRef r -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + -- No expression to associate with this value. + let bindings' = bindings & extendRegExprs NothingF + -- No App to memoize in this case. + let appMap' = appMap & appRegMap_extend + -- Resolve the atom + let r' = resolveAtom reg_map r + C.ConsStmt pl + (C.ReadRefCell r') + (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + EvalApp (fmapFC (resolveAtom reg_map) -> e) + | Just cr <- appRegMap_lookup e appMap -> do + let reg_map' = bindValueReg (AtomValue a) cr reg_map + resolveStmts nm bi sz reg_map' bindings appMap rest t + | otherwise -> do + let e' = C.App e + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + let bindings' = bindings & extendRegExprs (JustF e') + let appMap' = appMap & appRegMap_insert e (C.Reg (nextIndex sz)) + let stmt = C.SetReg (typeOfAtom a) e' + C.ConsStmt pl stmt (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + + FreshConstant bt cnm -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + let bindings' = bindings & extendRegExprs NothingF + let appMap' = appMap & appRegMap_extend + let stmt = C.FreshConstant bt cnm + C.ConsStmt pl stmt (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + + FreshFloat fi cnm -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + let bindings' = bindings & extendRegExprs NothingF + let appMap' = appMap & appRegMap_extend + let stmt = C.FreshFloat fi cnm + C.ConsStmt pl stmt (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + + FreshNat cnm -> do + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + let bindings' = bindings & extendRegExprs NothingF + let appMap' = appMap & appRegMap_extend + let stmt = C.FreshNat cnm + C.ConsStmt pl stmt (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + + Call h args _ -> do + let return_type = typeOfAtom a + let h' = resolveAtom reg_map h + let arg_types = fmapFC typeOfAtom args + let args' = fmapFC (resolveAtom reg_map) args + let stmt = C.CallHandle return_type h' arg_types args' + let sz' = incSize sz + let reg_map' = reg_map & assignRegister (AtomValue a) sz + let bindings' = bindings & extendRegExprs NothingF + let appMap' = appMap & appRegMap_extend + C.ConsStmt pl stmt (resolveStmts nm bi sz' reg_map' bindings' appMap' rest t) + + Print e -> do + C.ConsStmt pl + (C.Print (resolveAtom reg_map e)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + Assert c m -> + C.ConsStmt pl + (C.Assert (resolveAtom reg_map c) + (resolveAtom reg_map m)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + + Assume c m -> + C.ConsStmt pl + (C.Assume (resolveAtom reg_map c) + (resolveAtom reg_map m)) + (resolveStmts nm bi sz reg_map bindings appMap rest t) + + -- breakpoint statements are eliminated during the inferBlockInfo phase + Breakpoint{} -> error $ + "Unexpected breakpoint at position " ++ show p ++ ": " ++ show (Pretty.pretty s0) + +data SomeBlockMap ext ret where + SomeBlockMap :: + Ctx.Index blocks tp -> + Bimap BreakpointName (Some (C.BlockID blocks)) -> + C.BlockMap ext blocks ret -> + SomeBlockMap ext ret + +resolveBlockMap :: forall ext s ret + . C.IsSyntaxExtension ext + => FunctionName + -> Label s + -> [Block ext s ret] + -> SomeBlockMap ext ret +resolveBlockMap nm entry blocks = do + let resolveBlock :: BlockInfo ext s ret blocks + -> BlockInput ext s blocks ret args + -> C.Block ext blocks ret args + resolveBlock bi bin = do + let sz = size (binputArgs bin) + let regs = regMapFromAssignment (binputArgs bin) + let regExprs = Ctx.replicate sz NothingF + let appMap = appRegMap_empty + let stmts = Fold.toList $ binputStmts bin + let term = binputTerm bin + C.Block { C.blockID = binputID bin + , C.blockInputs = fmapFC typeOfValue (binputArgs bin) + , C._blockStmts = resolveStmts nm bi sz regs regExprs appMap stmts term + } + case inferBlockInfo blocks of + Some bi -> + case lookupJumpInfo entry (biJumpInfo bi) of + Nothing -> error "Missing initial block." + Just (JumpInfo (C.BlockID idx) _ _) -> + SomeBlockMap idx (biBreakpoints bi) $ + fmapFC (resolveBlock bi) (biBlocks bi) + +------------------------------------------------------------------------ +-- SomeCFG + +-- | Convert a CFG in RTL form into a Core CFG in SSA form. +-- +-- This prunes the CFG so that only reachable blocks are returned. +toSSA :: C.IsSyntaxExtension ext + => CFG ext s init ret + -> C.SomeCFG ext init ret +toSSA g = do + let h = cfgHandle g + let initTypes = cfgArgTypes g + let entry = cfgEntryLabel g + let blocks = cfgBlocks g + case resolveBlockMap (handleName h) entry blocks of + SomeBlockMap idx breakpoints block_map -> do + let b = block_map ! idx + case C.blockInputs b `testEquality` initTypes of + Nothing -> error $ + "Input block type " ++ show (C.blockInputs b) + ++ " does not match expected " ++ show initTypes + ++ ":\nwhile SSA converting function " ++ show h + Just Refl -> do + let g' = C.CFG { C.cfgHandle = h + , C.cfgBlockMap = block_map + , C.cfgEntryBlockID = C.BlockID idx + , C.cfgBreakpoints = breakpoints + } + reachableCFG g' diff --git a/src/Lang/Crucible/FunctionHandle.hs b/src/Lang/Crucible/FunctionHandle.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/FunctionHandle.hs @@ -0,0 +1,238 @@ +{- +Module : Lang.Crucible.FunctionHandle +Copyright : (c) Galois, Inc 2014-2016 +Maintainer : Joe Hendrix +License : BSD3 + +This provides handles to functions, which provides a unique +identifier of a function at runtime. Function handles can be thought of +as function pointers, but there are no operations to manipulate them. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.FunctionHandle + ( -- * Function handle + FnHandle + , handleID + , handleName + , handleArgTypes + , handleReturnType + , handleType + , SomeHandle(..) + -- * Allocate handle. + , HandleAllocator + , haCounter + , newHandleAllocator + , withHandleAllocator + , mkHandle + , mkHandle' + -- * FnHandleMap + , FnHandleMap + , emptyHandleMap + , insertHandleMap + , lookupHandleMap + , searchHandleMap + , handleMapToHandles + -- * Reference cells + , RefCell + , freshRefCell + , refType + ) where + +import Data.Hashable +import Data.Kind +import qualified Data.List as List +import Data.Ord (comparing) + +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Map (MapF) +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Nonce +import Data.Parameterized.Some ( Some(Some) ) + +import What4.FunctionName + +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- FunctionHandle + +-- | A handle uniquely identifies a function. The signature indicates the +-- expected argument types and the return type of the function. +data FnHandle (args :: Ctx CrucibleType) (ret :: CrucibleType) + = H { handleID :: !(Nonce GlobalNonceGenerator (args ::> ret)) + -- ^ A unique identifier for the function. + , handleName :: !FunctionName + -- ^ The name of the function (not necessarily unique) + , handleArgTypes :: !(CtxRepr args) + -- ^ The arguments types for the function + , handleReturnType :: !(TypeRepr ret) + -- ^ The return type of the function. + } + +instance Eq (FnHandle args ret) where + h1 == h2 = handleID h1 == handleID h2 + +instance Ord (FnHandle args ret) where + compare h1 h2 = comparing handleID h1 h2 + +instance Show (FnHandle args ret) where + show h = show (handleName h) + +instance Hashable (FnHandle args ret) where + hashWithSalt s h = hashWithSalt s (handleID h) + +-- | Return type of handle. +handleType :: FnHandle args ret -> TypeRepr (FunctionHandleType args ret) +handleType h = FunctionHandleRepr (handleArgTypes h) (handleReturnType h) + +------------------------------------------------------------------------ +-- SomeHandle + +-- | A function handle is a reference to a function in a given +-- run of the simulator. It has a set of expected arguments and return type. +data SomeHandle where + SomeHandle :: !(FnHandle args ret) -> SomeHandle + +instance Eq SomeHandle where + SomeHandle x == SomeHandle y = isJust (testEquality (handleID x) (handleID y)) + +instance Ord SomeHandle where + compare (SomeHandle x) (SomeHandle y) = toOrdering (compareF (handleID x) (handleID y)) + +instance Hashable SomeHandle where + hashWithSalt s (SomeHandle x) = hashWithSalt s (handleID x) + +instance Show SomeHandle where + show (SomeHandle h) = show (handleName h) + + +------------------------------------------------------------------------ +-- HandleAllocator + +-- | Used to allocate function handles. +newtype HandleAllocator + = HA () + +haCounter :: HandleAllocator -> NonceGenerator IO GlobalNonceGenerator +haCounter _ha = globalNonceGenerator + +-- | Create a new handle allocator. +newHandleAllocator :: IO (HandleAllocator) +newHandleAllocator = return (HA ()) + +-- | Create a new handle allocator and run the given computation. +withHandleAllocator :: (HandleAllocator -> IO a) -> IO a +withHandleAllocator k = newHandleAllocator >>= k + +-- | Allocate a new function handle with requested 'args' and 'ret' types +mkHandle :: (KnownCtx TypeRepr args, KnownRepr TypeRepr ret) + => HandleAllocator + -> FunctionName + -> IO (FnHandle args ret) +mkHandle a nm = mkHandle' a nm knownRepr knownRepr + +-- | Allocate a new function handle. +mkHandle' :: HandleAllocator + -> FunctionName + -> Ctx.Assignment TypeRepr args + -> TypeRepr ret + -> IO (FnHandle args ret) +mkHandle' _ha nm args ret = do + i <- freshNonce globalNonceGenerator + return $! H { handleID = i + , handleName = nm + , handleArgTypes = args + , handleReturnType = ret + } + +------------------------------------------------------------------------ +-- Reference cells + +data RefCell (tp :: CrucibleType) + = RefCell (TypeRepr tp) (Nonce GlobalNonceGenerator tp) + +refType :: RefCell tp -> TypeRepr tp +refType (RefCell tpr _) = tpr + +freshRefCell :: HandleAllocator + -> TypeRepr tp + -> IO (RefCell tp) +freshRefCell _ha tpr = + RefCell tpr <$> freshNonce globalNonceGenerator + +instance Show (RefCell tp) where + show (RefCell _ n) = show n + +instance ShowF RefCell where + +instance TestEquality RefCell where + testEquality (RefCell _ x) (RefCell _ y) = + case testEquality x y of + Just Refl -> Just Refl + Nothing -> Nothing + +instance OrdF RefCell where + compareF (RefCell _tx x) (RefCell _ty y) = + case compareF x y of + LTF -> LTF + EQF -> EQF + GTF -> GTF + +instance Eq (RefCell tp) where + x == y = isJust (testEquality x y) + +instance Ord (RefCell tp) where + compare x y = toOrdering (compareF x y) + +------------------------------------------------------------------------ +-- FnHandleMap + +data HandleElt (f :: Ctx CrucibleType -> CrucibleType -> Type) ctx where + HandleElt :: FnHandle args ret -> f args ret -> HandleElt f (args::>ret) + +newtype FnHandleMap f = FnHandleMap (MapF (Nonce GlobalNonceGenerator) (HandleElt f)) + +emptyHandleMap :: FnHandleMap f +emptyHandleMap = FnHandleMap MapF.empty + +insertHandleMap :: FnHandle args ret + -> f args ret + -> FnHandleMap f + -> FnHandleMap f +insertHandleMap hdl x (FnHandleMap m) = + FnHandleMap (MapF.insert (handleID hdl) (HandleElt hdl x) m) + +-- | Lookup the function specification in the map via the Nonce index +-- in the FnHandle argument. +lookupHandleMap :: FnHandle args ret + -> FnHandleMap f + -> Maybe (f args ret) +lookupHandleMap hdl (FnHandleMap m) = + case MapF.lookup (handleID hdl) m of + Just (HandleElt _ x) -> Just x + Nothing -> Nothing + +-- | Lookup the function name in the map by a linear scan of all +-- entries. This will be much slower than using 'lookupHandleMap' to +-- find the function by ID, so the latter should be used if possible. +searchHandleMap :: FunctionName + -> (TypeRepr (FunctionHandleType args ret)) + -> FnHandleMap f + -> Maybe (FnHandle args ret, f args ret) +searchHandleMap nm fnTyRepr (FnHandleMap m) = + let nameMatch (Some (HandleElt h _)) = handleName h == nm + in case List.find nameMatch (MapF.elems m) of + Nothing -> Nothing + (Just (Some (HandleElt h x))) -> + case testEquality (handleType h) fnTyRepr of + Just Refl -> Just (h,x) + Nothing -> Nothing + +handleMapToHandles :: FnHandleMap f -> [SomeHandle] +handleMapToHandles (FnHandleMap m) = + map (\(Some (HandleElt handle _)) -> SomeHandle handle) (MapF.elems m) diff --git a/src/Lang/Crucible/Panic.hs b/src/Lang/Crucible/Panic.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Panic.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Trustworthy, TemplateHaskell #-} +module Lang.Crucible.Panic + (HasCallStack, Crucible, Panic, panic) where + +import Panic hiding (panic) +import qualified Panic + +data Crucible = Crucible + +panic :: HasCallStack => String -> [String] -> a +panic = Panic.panic Crucible + +instance PanicComponent Crucible where + panicComponentName _ = "Crucible" + panicComponentIssues _ = "https://github.com/GaloisInc/crucible/issues" + + {-# Noinline panicComponentRevision #-} + panicComponentRevision = $useGitRevision diff --git a/src/Lang/Crucible/Simulator.hs b/src/Lang/Crucible/Simulator.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator +-- Description : Reexports of relevant parts of submodules +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module reexports the parts of the symbolic simulator codebase +-- that are most relevant for users. Additional types and operations +-- are exported from the relevant submodules if necessary. +------------------------------------------------------------------------ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator + ( -- * Register values + RegValue + , RegValue'(..) + -- ** Variants + , VariantBranch(..) + , injectVariant + -- ** Any Values + , AnyValue(..) + -- ** Function Values + , FnVal(..) + , fnValType + -- ** Recursive Values + , RolledType(..) + + -- * Register maps + , RegEntry(..) + , RegMap(..) + , emptyRegMap + , regVal + , assignReg + , reg + + -- * SimError + , SimErrorReason(..) + , SimError(..) + , ppSimError + + -- * SimGlobalState + , GlobalVar(..) + , SymGlobalState + , emptyGlobals + + -- * GlobalPair + , GlobalPair(..) + , gpValue + , gpGlobals + + -- * AbortedResult + , AbortedResult(..) + + -- * Partial result + , PartialResult(..) + , partialValue + + -- * Execution states + , ExecResult(..) + , ExecState(..) + , ExecCont + , execResultContext + + -- * Simulator context + -- ** Function bindings + , Override(..) + , FnState(..) + , FunctionBindings(..) + + -- ** Extensions + , ExtensionImpl(..) + , EvalStmtFunc + , emptyExtensionImpl + + -- ** SimContext record + , IsSymInterfaceProof + , SimContext(..) + , initSimContext + , ctxSymInterface + , functionBindings + , cruciblePersonality + , profilingMetrics + + -- * SimState + , SimState + , initSimState + , defaultAbortHandler + , AbortHandler(..) + , CrucibleState + , stateContext + + -- * Intrinsic types + , IntrinsicClass + , IntrinsicMuxFn(..) + , IntrinsicTypes + , emptyIntrinsicTypes + + -- * Evaluation + , executeCrucible + , singleStepCrucible + , evalReg + , evalArgs + , stepStmt + , stepTerm + , stepBasicBlock + , ExecutionFeature + , GenericExecutionFeature + , genericToExecutionFeature + , timeoutFeature + + -- * OverrideSim monad + , module Lang.Crucible.Simulator.OverrideSim + ) where + +import Lang.Crucible.CFG.Common +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.Operations +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError diff --git a/src/Lang/Crucible/Simulator/BoundedExec.hs b/src/Lang/Crucible/Simulator/BoundedExec.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/BoundedExec.hs @@ -0,0 +1,300 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.BoundedExec +-- Description : Support for bounding loop depth +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module provides an execution feature for bounding the +-- number of iterations that a loop will execute in the simulator. +------------------------------------------------------------------------ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Lang.Crucible.Simulator.BoundedExec + ( boundedExecFeature + ) where + +import Control.Lens ( (^.), to, (&), (%~), (.~) ) +import Control.Monad ( when ) +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import Data.Word + + +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF + +import Lang.Crucible.Analysis.Fixpoint.Components +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Core +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.SimError + +import What4.FunctionName +import What4.Interface + +data FrameBoundData = + forall args ret. + FrameBoundData + { frameBoundHandle :: !(FnHandle args ret) + , frameBoundLimit :: !Word64 + , frameWtoMap :: !(Map Int (Int,Int)) + , frameBoundCounts :: Seq Word64 + } + +-- | This function takes weak topological order data and computes +-- a mapping from block ID number to (position, depth) pair. The +-- position value indicates which the position in the WTO listing +-- in which the block ID appears, and the depth indicates the number +-- of nested components the block ID appears in. Loop backedges +-- occur exactly at places where control flows from a higher position +-- number to a lower position number. Jumps that exit inner loops +-- to the next iteration of an outer loop are identified by backedges +-- that pass from higher depths to lower depths. +buildWTOMap :: [WTOComponent (Some (BlockID blocks))] -> Map Int (Int,Int) +buildWTOMap = snd . go 0 0 Map.empty + where + go :: Int -> Int -> Map Int (Int,Int) -> [WTOComponent (Some (BlockID blocks))] -> (Int, Map Int (Int,Int)) + go !x !_ m [] = (x,m) + go !x !d m (Vertex (Some bid) : cs) = + let m' = Map.insert (Ctx.indexVal (blockIDIndex bid)) (x,d) m + in go (x+1) d m' cs + go !x !d m (SCC scc : cs) = + let m' = viewSome (\hd -> Map.insert (Ctx.indexVal (blockIDIndex hd)) (x,d+1) m) (wtoHead scc) + (x',m'') = go (x+1) (d+1) m' $ wtoComps scc + in go x' d m'' cs + + +-- | This function updates the loop bound count at the given depth. +-- Any loop bounds deeper than this are discarded. If the given +-- sequence is too short to accommodate the given depth, the sequence +-- is extended with 0 counters to the correct depth. +incrementBoundCount :: Seq Word64 -> Int -> (Seq Word64, Word64) +incrementBoundCount cs depth = + case Seq.lookup depth cs of + Just n -> + do let n' = n+1 + let cs' = Seq.update depth n' $ Seq.take (depth+1) cs + n' `seq` cs' `seq` (cs', n') + Nothing -> + do let cs' = cs <> Seq.replicate (depth - Seq.length cs) 0 <> Seq.singleton 1 + cs' `seq` (cs', 1) + +instance IntrinsicClass sym "BoundedExecFrameData" where + type Intrinsic sym "BoundedExecFrameData" ctx = [Either FunctionName FrameBoundData] + + muxIntrinsic _sym _iTypes _nm _ _p fd1 fd2 = combineFrameBoundData fd1 fd2 + +mergeCounts :: Seq Word64 -> Seq Word64 -> Seq Word64 +mergeCounts cx cy = + Seq.fromFunction + (max (Seq.length cx) (Seq.length cy)) + (\i -> max (fromMaybe 0 $ Seq.lookup i cx) + (fromMaybe 0 $ Seq.lookup i cy)) + +mergeFBD :: + FrameBoundData -> + FrameBoundData -> + IO FrameBoundData +mergeFBD x@FrameBoundData{ frameBoundHandle = hx } y@FrameBoundData{ frameBoundHandle = hy } + | Just _ <- testEquality (handleID hx) (handleID hy) = + return x{ frameBoundCounts = mergeCounts (frameBoundCounts x) (frameBoundCounts y) } + + | otherwise = + panic "BoundedExec.mergeFBD" + [ "Attempted to merge frame bound data from different function activations: " + , " ** " ++ show hx + , " ** " ++ show hy + ] + + +combineFrameBoundData :: + [Either FunctionName FrameBoundData] -> + [Either FunctionName FrameBoundData] -> + IO [Either FunctionName FrameBoundData] +combineFrameBoundData [] [] = return [] + +combineFrameBoundData (Left nmx:xs) (Left nmy : _) | nmx == nmy + = return (Left nmx : xs) + +combineFrameBoundData (Right x:xs) (Right y:_) + = (\x' -> Right x' : xs) <$> mergeFBD x y + +combineFrameBoundData xs ys + = panic "BoundedExec.combineFrameBoundData" + [ "Attempt to combine incompatible frame bound data: stack shape mismatch:" + , " *** " ++ show (printStack xs) + , " *** " ++ show (printStack ys) + ] + +printStack :: [Either FunctionName FrameBoundData] -> [String] +printStack [] = [] +printStack (Left nm :xs) = show nm : printStack xs +printStack (Right FrameBoundData{ frameBoundHandle = h } : xs) = show h : printStack xs + + +type BoundedExecGlobal = GlobalVar (IntrinsicType "BoundedExecFrameData" EmptyCtx) + + +-- | This execution feature allows users to place a bound on the number +-- of iterations that a loop will execute. Each time a function is called, +-- the included action is called to determine if the loops in that function +-- should be bounded, and what their iteration bound should be. +-- +-- The boolean argument indicates if we should generate proof obligations when +-- we cut off loop execution. If true, loop cutoffs will generate proof obligations +-- which will be provable only if the loop actually could not have executed that number +-- of iterations. If false, the execution of loops will be aborted without generating +-- side conditions. +-- +-- Note that we compute a weak topological ordering on control flow graphs +-- to determine loop heads and loop nesting structure. Loop bounds for inner +-- loops are reset on every iteration through an outer loop. +boundedExecFeature :: + (SomeHandle -> IO (Maybe Word64)) + {- ^ Action for computing loop bounds for functions when they are called -} -> + Bool {- ^ Produce a proof obligation when resources are exhausted? -} -> + IO (GenericExecutionFeature sym) +boundedExecFeature getLoopBounds generateSideConditions = + do gvRef <- newIORef (error "Global variable for BoundedExecFrameData not initialized") + return $ GenericExecutionFeature $ onStep gvRef + + where + buildFrameData :: ResolvedCall p sym ext ret -> IO (Either FunctionName FrameBoundData) + buildFrameData (OverrideCall ov _) = return (Left (overrideName ov)) + buildFrameData (CrucibleCall _entry CallFrame{ _frameCFG = g }) = + do let wtoMap = buildWTOMap (cfgWeakTopologicalOrdering g) + mn <- getLoopBounds (SomeHandle (cfgHandle g)) + case mn of + Nothing -> return $ Left $ handleName (cfgHandle g) + Just n -> return $ Right $ FrameBoundData + { frameBoundHandle = cfgHandle g + , frameBoundLimit = n + , frameWtoMap = wtoMap + , frameBoundCounts = mempty + } + + checkBackedge :: + IORef BoundedExecGlobal -> + Some (BlockID blocks) -> + BlockID blocks tgt_args -> + SymGlobalState sym -> + IO (SymGlobalState sym, Maybe Word64) + checkBackedge gvRef (Some bid_curr) bid_tgt globals = + do gv <- readIORef gvRef + case fromMaybe [] (lookupGlobal gv globals) of + ( Right fbd : rest ) -> + do let id_curr = Ctx.indexVal (blockIDIndex bid_curr) + let id_tgt = Ctx.indexVal (blockIDIndex bid_tgt) + let m = frameWtoMap fbd + case (Map.lookup id_curr m, Map.lookup id_tgt m) of + (Just (cx, _cd), Just (tx, td)) | tx <= cx -> + do let cs = frameBoundCounts fbd + let (cs', q) = incrementBoundCount cs td + let fbd' = fbd{ frameBoundCounts = cs' } + let globals' = insertGlobal gv (Right fbd' : rest) globals + if q > frameBoundLimit fbd then + return (globals', Just (frameBoundLimit fbd)) + else + return (globals', Nothing) + + _ -> return (globals, Nothing) + _ -> return (globals, Nothing) + + modifyStackState :: + IORef BoundedExecGlobal -> + (SimState p sym ext rtp f args -> ExecState p sym ext rtp) -> + SimState p sym ext rtp f args -> + ([Either FunctionName FrameBoundData] -> [Either FunctionName FrameBoundData]) -> + IO (ExecutionFeatureResult p sym ext rtp) + modifyStackState gvRef mkSt st f = + do gv <- readIORef gvRef + let xs = case lookupGlobal gv (st ^. stateGlobals) of + Nothing -> error "bounded execution global not defined!" + Just v -> v + let st' = st & stateGlobals %~ insertGlobal gv (f xs) + return (ExecutionFeatureModifiedState (mkSt st')) + + onTransition :: + IORef BoundedExecGlobal -> + BlockID blocks tgt_args -> + ControlResumption p sym ext rtp (CrucibleLang blocks ret) -> + SimState p sym ext rtp (CrucibleLang blocks ret) ('Just a) -> + IO (ExecutionFeatureResult p sym ext rtp) + onTransition gvRef tgt_id res st = stateSolverProof st $ + do let sym = st^.stateSymInterface + let simCtx = st^.stateContext + (globals', overLimit) <- checkBackedge gvRef (st^.stateCrucibleFrame.frameBlockID) tgt_id (st^.stateGlobals) + let st' = st & stateGlobals .~ globals' + case overLimit of + Just n -> + do let msg = "reached maximum number of loop iterations (" ++ show n ++ ")" + let loc = st^.stateCrucibleFrame.to frameProgramLoc + let err = SimError loc (ResourceExhausted msg) + when generateSideConditions $ withBackend simCtx $ \bak -> + addProofObligation bak (LabeledPred (falsePred sym) err) + return (ExecutionFeatureNewState (AbortState (AssertionFailure err) st')) + Nothing -> return (ExecutionFeatureModifiedState (ControlTransferState res st')) + + onStep :: + IORef BoundedExecGlobal -> + ExecState p sym ext rtp -> + IO (ExecutionFeatureResult p sym ext rtp) + + onStep gvRef = \case + InitialState simctx globals ah ret cont -> + do let halloc = simHandleAllocator simctx + gv <- freshGlobalVar halloc (Text.pack "BoundedExecFrameData") knownRepr + writeIORef gvRef gv + let globals' = insertGlobal gv [Left "_init"] globals + let simctx' = simctx{ ctxIntrinsicTypes = MapF.insert (knownSymbol @"BoundedExecFrameData") IntrinsicMuxFn (ctxIntrinsicTypes simctx) } + return (ExecutionFeatureModifiedState (InitialState simctx' globals' ah ret cont)) + + CallState rh call st -> + do boundData <- buildFrameData call + modifyStackState gvRef (CallState rh call) st (boundData:) + + TailCallState vfv call st -> + do boundData <- buildFrameData call + modifyStackState gvRef (TailCallState vfv call) st ((boundData:) . drop 1) + + ReturnState nm vfv pr st -> + modifyStackState gvRef (ReturnState nm vfv pr) st (drop 1) + + UnwindCallState vfv ar st -> + modifyStackState gvRef (UnwindCallState vfv ar) st (drop 1) + + ControlTransferState res st -> + case res of + ContinueResumption (ResolvedJump tgt_id _) -> onTransition gvRef tgt_id res st + CheckMergeResumption (ResolvedJump tgt_id _) -> onTransition gvRef tgt_id res st + _ -> return ExecutionFeatureNoChange + + _ -> return ExecutionFeatureNoChange diff --git a/src/Lang/Crucible/Simulator/BoundedRecursion.hs b/src/Lang/Crucible/Simulator/BoundedRecursion.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/BoundedRecursion.hs @@ -0,0 +1,162 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.BoundedRecursion +-- Description : Support for bounding function recursion depth +-- Copyright : (c) Galois, Inc 2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module provides an execution feature for bounding recursion. +-- Essentially, we bound the number of times any particular function +-- is allowed to have active frames on the call stack. +------------------------------------------------------------------------ + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Lang.Crucible.Simulator.BoundedRecursion + ( boundedRecursionFeature + ) where + +import Control.Lens ( (^.), (&), (%~) ) +import Control.Monad (when) +import Data.IORef +import Data.Maybe +import qualified Data.Text as Text +import Data.Word +import qualified Data.Map.Strict as Map + +import Data.Parameterized.Ctx +import qualified Data.Parameterized.Map as MapF + +import What4.Interface + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Types + +type BoundedRecursionMap = Map.Map SomeHandle Word64 + +instance IntrinsicClass sym "BoundedRecursionData" where + type Intrinsic sym "BoundedRecursionData" ctx = [BoundedRecursionMap] + muxIntrinsic _sym _iTypes _nm _ _p x _y = return x + +type BoundedRecursionGlobal = GlobalVar (IntrinsicType "BoundedRecursionData" EmptyCtx) + +-- | This execution feature allows users to place a bound on the number of +-- recursive calls that a function can execute. Each time a function is +-- called, the number of activations of the functions is incremented, and +-- the path is aborted if the bound is exceeded. +-- +-- The boolean argument indicates if we should generate proof obligations when +-- we cut off recursion. If true, recursion cutoffs will generate proof obligations +-- which will be provable only if the function actually could not have executed that number +-- of times. If false, the execution of recursive functions will be aborted without +-- generating side conditions. +boundedRecursionFeature :: + (SomeHandle -> IO (Maybe Word64)) + {- ^ Action for computing what recursion depth to allow for the given function -} -> + Bool {- ^ Produce a proof obligation when resources are exhausted? -} -> + IO (GenericExecutionFeature sym) + +boundedRecursionFeature getRecursionBound generateSideConditions = + do gvRef <- newIORef (error "Global variable for BoundedRecursionData not initialized") + return $ GenericExecutionFeature $ onStep gvRef + + where + popFrame :: + IORef BoundedRecursionGlobal -> + (SimState p sym ext rtp f args -> ExecState p sym ext rtp) -> + SimState p sym ext rtp f args -> + IO (ExecutionFeatureResult p sym ext rtp) + popFrame gvRef mkSt st = + do gv <- readIORef gvRef + case lookupGlobal gv (st ^. stateGlobals) of + Nothing -> panic "bounded recursion" ["global not defined!"] + Just [] -> panic "bounded recursion" ["pop on empty stack!"] + Just (_:xs) -> + do let st' = st & stateGlobals %~ insertGlobal gv xs + return (ExecutionFeatureModifiedState (mkSt st')) + + pushFrame :: + IORef BoundedRecursionGlobal -> + (BoundedRecursionMap -> BoundedRecursionMap -> [BoundedRecursionMap] -> [BoundedRecursionMap]) -> + SomeHandle -> + (SimState p sym ext rtp f args -> ExecState p sym ext rtp) -> + SimState p sym ext rtp f args -> + IO (ExecutionFeatureResult p sym ext rtp) + pushFrame gvRef rebuildStack h mkSt st = stateSolverProof st $ + do let sym = st^.stateSymInterface + let simCtx = st^.stateContext + gv <- readIORef gvRef + case lookupGlobal gv (st ^. stateGlobals) of + Nothing -> panic "bounded recursion" ["global not defined!"] + Just [] -> panic "bounded recursion" ["empty stack!"] + Just (x:xs) -> + do mb <- getRecursionBound h + let v = 1 + fromMaybe 0 (Map.lookup h x) + case mb of + Just b | v > b -> + do loc <- getCurrentProgramLoc sym + let msg = ("reached maximum number of recursive calls to function " ++ show h ++ " (" ++ show b ++ ")") + let err = SimError loc (ResourceExhausted msg) + when generateSideConditions $ withBackend simCtx $ \bak -> + addProofObligation bak (LabeledPred (falsePred sym) err) + return (ExecutionFeatureNewState (AbortState (AssertionFailure err) st)) + _ -> + do let x' = Map.insert h v x + let st' = st & stateGlobals %~ insertGlobal gv (rebuildStack x' x xs) + x' `seq` return (ExecutionFeatureModifiedState (mkSt st')) + + onStep :: + IORef BoundedRecursionGlobal -> + ExecState p sym ext rtp -> + IO (ExecutionFeatureResult p sym ext rtp) + + onStep gvRef = \case + + InitialState simctx globals ah ret cont -> + do let halloc = simHandleAllocator simctx + gv <- freshGlobalVar halloc (Text.pack "BoundedRecursionData") knownRepr + writeIORef gvRef gv + let simctx' = simctx{ ctxIntrinsicTypes = MapF.insert + (knownSymbol @"BoundedRecursionData") + IntrinsicMuxFn + (ctxIntrinsicTypes simctx) } + let globals' = insertGlobal gv [mempty] globals + return (ExecutionFeatureModifiedState (InitialState simctx' globals' ah ret cont)) + + CallState rh call st -> + pushFrame gvRef (\a b xs -> a:b:xs) (resolvedCallHandle call) (CallState rh call) st + + TailCallState vfv call st -> + pushFrame gvRef (\a _ xs -> a:xs) (resolvedCallHandle call) (TailCallState vfv call) st + + ReturnState nm vfv pr st -> + popFrame gvRef (ReturnState nm vfv pr) st + + UnwindCallState vfv ar st -> + popFrame gvRef (UnwindCallState vfv ar) st + + _ -> return ExecutionFeatureNoChange diff --git a/src/Lang/Crucible/Simulator/Breakpoint.hs b/src/Lang/Crucible/Simulator/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/Breakpoint.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.Breakpoint +-- Description : Support for symbolic execution breakpoints +-- Copyright : (c) Galois, Inc 2019 +-- License : BSD3 +-- Maintainer : Andrei Stefanescu +-- Stability : provisional +-- +-- This module provides execution features for changing the state on +-- breakpoints. +----------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module Lang.Crucible.Simulator.Breakpoint + ( breakAndReturn + ) where + +import Control.Lens +import Control.Monad.Reader +import qualified Data.Bimap as Bimap +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some +import Data.Parameterized.TraversableFC + +import qualified Lang.Crucible.Backend as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Expr as C +import qualified Lang.Crucible.Simulator.CallFrame as C +import qualified Lang.Crucible.Simulator.EvalStmt as C +import qualified Lang.Crucible.Simulator.ExecutionTree as C +import qualified Lang.Crucible.Simulator.Operations as C +import qualified Lang.Crucible.Simulator.OverrideSim as C +import qualified Lang.Crucible.Simulator.RegValue as C +import qualified What4.FunctionName as W + +-- | This execution feature registers an override for a breakpoint. +-- The override summarizes the execution from the breakpoint +-- to the return from the function (similar to a tail call). +-- This feature requires a map from each function handle +-- to the list of breakpoints in the respective function with this +-- execution feature. +breakAndReturn :: + (C.IsSymInterface sym, C.IsSyntaxExtension ext) => + C.CFG ext blocks init ret -> + C.BreakpointName -> + Ctx.Assignment C.TypeRepr args -> + C.TypeRepr ret -> + C.OverrideSim p sym ext rtp args ret (C.RegValue sym ret) -> + HashMap C.SomeHandle [C.BreakpointName] -> + IO (C.ExecutionFeature p sym ext rtp) +breakAndReturn C.CFG{..} breakpoint_name arg_types ret_type override all_breakpoints = + case Bimap.lookup breakpoint_name cfgBreakpoints of + Just (Some breakpoint_block_id) + | breakpoint_block <- C.getBlock breakpoint_block_id cfgBlockMap + , Just Refl <- testEquality (C.blockInputs breakpoint_block) arg_types -> + return $ C.ExecutionFeature $ \case + C.RunningState (C.RunPostBranchMerge block_id) state + | frame <- state ^. C.stateCrucibleFrame + , C.SomeHandle cfgHandle == C.frameHandle frame + , Just Refl <- testEquality + (fmapFC C.blockInputs cfgBlockMap) + (fmapFC C.blockInputs $ C.frameBlockMap frame) + , Just Refl <- testEquality breakpoint_block_id block_id + , Just Refl <- testEquality ret_type (C.frameReturnType frame) -> do + let override_frame = C.OF $ C.OverrideFrame + { _override = W.functionNameFromText $ + C.breakpointNameText breakpoint_name + , _overrideHandle = C.frameHandle frame + , _overrideRegMap = state ^. + C.stateCrucibleFrame . C.frameRegs + } + result_state <- runReaderT (C.runOverrideSim ret_type override) $ + state & C.stateTree %~ + C.pushCallFrame C.TailReturnToCrucible override_frame + return $ C.ExecutionFeatureNewState result_state + C.CallState return_handler (C.CrucibleCall block_id frame) state + | Just breakpoints <- HashMap.lookup + (C.frameHandle frame) + all_breakpoints -> do + let result_frame = C.setFrameBreakpointPostdomInfo + breakpoints + frame + result_state <- runReaderT + (C.performFunctionCall + return_handler + (C.CrucibleCall block_id result_frame)) + state + return $ C.ExecutionFeatureNewState result_state + C.TailCallState value_from_value (C.CrucibleCall block_id frame) state + | Just breakpoints <- HashMap.lookup + (C.frameHandle frame) + all_breakpoints -> do + let result_frame = C.setFrameBreakpointPostdomInfo + breakpoints + frame + result_state <- runReaderT + (C.performTailCall + value_from_value + (C.CrucibleCall block_id result_frame)) + state + return $ C.ExecutionFeatureNewState result_state + _ -> return C.ExecutionFeatureNoChange + _ -> fail $ "unexpected breakpoint: " ++ show breakpoint_name diff --git a/src/Lang/Crucible/Simulator/CallFrame.hs b/src/Lang/Crucible/Simulator/CallFrame.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/CallFrame.hs @@ -0,0 +1,324 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.CallFrame +-- Description : Data structure for call frames in the simulator +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- Call frames are used to record information about suspended stack +-- frames when functions are called. +------------------------------------------------------------------------ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.CallFrame + ( -- * CrucibleBranchTarget + CrucibleBranchTarget(..) + , ppBranchTarget + -- * Call frame + , CallFrame(..) + , mkCallFrame + , mkBlockFrame + , framePostdomMap + , frameBlockMap + , frameHandle + , frameReturnType + , frameBlockID + , frameRegs + , frameStmts + , framePostdom + , frameProgramLoc + , setFrameBlock + , setFrameBreakpointPostdomInfo + , extendFrame + , updateFrame + , mergeCallFrame + -- * SomeHandle + , SomeHandle(..) + -- * Simulator frames + , SimFrame(..) + , CrucibleLang + , OverrideLang + , FrameRetType + , OverrideFrame(..) + , override + , overrideHandle + , overrideRegMap + , overrideSimFrame + , crucibleSimFrame + , fromCallFrame + , fromReturnFrame + , frameFunctionName + ) where + +import Control.Lens +import Data.Kind +import qualified Data.Parameterized.Context as Ctx + +import What4.FunctionName +import What4.Interface ( Pred ) +import What4.ProgramLoc ( ProgramLoc ) + +import Lang.Crucible.Analysis.Postdom +import Lang.Crucible.CFG.Core +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Backend + + +------------------------------------------------------------------------ +-- CrucibleBranchTarget + +-- | A 'CrucibleBranchTarget' identifies a program location that is a +-- potential join point. Each label is a merge point, and there is +-- an additional implicit join point at function returns. +data CrucibleBranchTarget f (args :: Maybe (Ctx CrucibleType)) where + BlockTarget :: + !(BlockID blocks args) -> + CrucibleBranchTarget (CrucibleLang blocks r) ('Just args) + ReturnTarget :: + CrucibleBranchTarget f 'Nothing + +instance TestEquality (CrucibleBranchTarget f) where + testEquality (BlockTarget x) (BlockTarget y) = + case testEquality x y of + Just Refl -> Just Refl + Nothing -> Nothing + testEquality ReturnTarget ReturnTarget = Just Refl + testEquality _ _ = Nothing + +ppBranchTarget :: CrucibleBranchTarget f args -> String +ppBranchTarget (BlockTarget b) = "merge: " ++ show b +ppBranchTarget ReturnTarget = "return" + + +------------------------------------------------------------------------ +-- CallFrame + +-- | A call frame for a crucible block. +data CallFrame sym ext blocks ret args + = forall initialArgs. + CallFrame + { _frameCFG :: CFG ext blocks initialArgs ret + -- ^ Handle to control flow graph for the current frame. + , _framePostdomMap :: !(CFGPostdom blocks) + -- ^ Post-dominator map for control flow graph associated with this + -- function. + , _frameBlockID :: !(Some (BlockID blocks)) + , _frameRegs :: !(RegMap sym args) + , _frameStmts :: !(StmtSeq ext blocks ret args) + , _framePostdom :: !(Some (CrucibleBranchTarget (CrucibleLang blocks ret))) + } + +frameBlockMap :: CallFrame sym ext blocks ret ctx -> BlockMap ext blocks ret +frameBlockMap CallFrame { _frameCFG = g } = cfgBlockMap g + +frameHandle :: CallFrame sym ext blocks ret ctx -> SomeHandle +frameHandle CallFrame { _frameCFG = g } = SomeHandle (cfgHandle g) + +frameReturnType :: CallFrame sym ext blocks ret ctx -> TypeRepr ret +frameReturnType CallFrame { _frameCFG = g } = cfgReturnType g + +framePostdomMap :: Simple Lens (CallFrame sym ext blocks ret ctx) (CFGPostdom blocks) +framePostdomMap = lens _framePostdomMap (\s x -> s{ _framePostdomMap = x }) + +frameBlockID :: Simple Lens (CallFrame sym ext blocks ret ctx) (Some (BlockID blocks)) +frameBlockID = lens _frameBlockID (\s v -> s { _frameBlockID = v }) + +-- | List of statements to execute next. +frameStmts :: Simple Lens (CallFrame sym ext blocks ret ctx) (StmtSeq ext blocks ret ctx) +frameStmts = lens _frameStmts (\s v -> s { _frameStmts = v }) +{-# INLINE frameStmts #-} + +frameRegs :: Simple Lens (CallFrame sym ext blocks ret args) (RegMap sym args) +frameRegs = lens _frameRegs (\s v -> s { _frameRegs = v }) + +-- | List of statements to execute next. +framePostdom :: Simple Lens (CallFrame sym ext blocks ret ctx) (Some (CrucibleBranchTarget (CrucibleLang blocks ret))) +framePostdom = lens _framePostdom (\s v -> s { _framePostdom = v }) + +-- | Create a new call frame. +mkCallFrame :: CFG ext blocks init ret + -- ^ Control flow graph + -> CFGPostdom blocks + -- ^ Post dominator information. + -> RegMap sym init + -- ^ Initial arguments + -> CallFrame sym ext blocks ret init +mkCallFrame g = mkBlockFrame g (cfgEntryBlockID g) + +-- | Create a new call frame. +mkBlockFrame :: + CFG ext blocks init ret {- ^ Control flow graph -} -> + BlockID blocks args {- ^ Entry point -} -> + CFGPostdom blocks {- ^ Post dominator information -} -> + RegMap sym args {- ^ Initial arguments -} -> + CallFrame sym ext blocks ret args +mkBlockFrame g bid@(BlockID block_id) pdInfo args = do + let b = cfgBlockMap g Ctx.! block_id + let pds = getConst $ pdInfo Ctx.! block_id + CallFrame { _frameCFG = g + , _framePostdomMap = pdInfo + , _frameBlockID = Some bid + , _frameRegs = args + , _frameStmts = b^.blockStmts + , _framePostdom = mkFramePostdom pds + } + +mkFramePostdom :: [Some (BlockID blocks)] -> Some (CrucibleBranchTarget (CrucibleLang blocks ret)) +mkFramePostdom [] = Some ReturnTarget +mkFramePostdom (Some i:_) = Some (BlockTarget i) + + +-- | Return program location associated with frame. +frameProgramLoc :: CallFrame sym ext blocks ret ctx -> ProgramLoc +frameProgramLoc cf = firstStmtLoc (cf^.frameStmts) + +setFrameBlock :: BlockID blocks args + -> RegMap sym args + -> CallFrame sym ext blocks ret ctx + -> CallFrame sym ext blocks ret args +setFrameBlock bid@(BlockID block_id) args f = f' + where b = frameBlockMap f Ctx.! block_id + pds = getConst $ (f^.framePostdomMap.ixF block_id) + f' = f { _frameBlockID = Some bid + , _frameRegs = args + , _frameStmts = b^.blockStmts + , _framePostdom = mkFramePostdom pds + } + +setFrameBreakpointPostdomInfo :: + [BreakpointName] -> + CallFrame sym ext blocks ret ctx -> + CallFrame sym ext blocks ret ctx +setFrameBreakpointPostdomInfo breakpoints f = case f of + CallFrame{ _frameCFG = g, _frameBlockID = Some (BlockID block_id) } -> do + let pdInfo = breakpointPostdomInfo g breakpoints + f { _framePostdomMap = pdInfo + , _framePostdom = mkFramePostdom (getConst $ pdInfo Ctx.! block_id) + } + +updateFrame :: RegMap sym ctx' + -> BlockID blocks ctx + -> StmtSeq ext blocks ret ctx' + -> CallFrame sym ext blocks ret ctx + -> CallFrame sym ext blocks ret ctx' +updateFrame r b s f = f { _frameBlockID = Some b, _frameRegs = r, _frameStmts = s } + +-- | Extend frame with new register. +extendFrame :: TypeRepr tp + -> RegValue sym tp + -> StmtSeq ext blocks ret (ctx ::> tp) + -> CallFrame sym ext blocks ret ctx + -> CallFrame sym ext blocks ret (ctx ::> tp) +extendFrame tp v s f = f { _frameRegs = assignReg tp v (_frameRegs f) + , _frameStmts = s + } + +mergeCallFrame :: IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> MuxFn (Pred sym) (CallFrame sym ext blocks ret args) +mergeCallFrame s iteFns p xcf ycf = do + r <- mergeRegs s iteFns p (_frameRegs xcf) (_frameRegs ycf) + return $ xcf { _frameRegs = r } + + +------------------------------------------------------------------------ +-- CrucibleLang + +-- | Nominal type for identifying override frames. +data CrucibleLang (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType) + +------------------------------------------------------------------------ +-- OverrideLang + +-- | Nominal type for identifying override frames. +data OverrideLang (ret :: CrucibleType) + +------------------------------------------------------------------------ +-- OverrideFrame + +-- | Frame in call to override. +data OverrideFrame sym (ret :: CrucibleType) args + = OverrideFrame { _override :: !FunctionName + , _overrideHandle :: !SomeHandle + , _overrideRegMap :: !(RegMap sym args) + -- ^ Arguments to override. + } + +override :: Simple Lens (OverrideFrame sym ret args) FunctionName +override = lens _override (\o x -> o{ _override = x }) + +overrideHandle :: Simple Lens (OverrideFrame sym ret args) SomeHandle +overrideHandle = lens _overrideHandle (\o x -> o { _overrideHandle = x }) + +overrideRegMap :: Lens (OverrideFrame sym ret args) (OverrideFrame sym ret args') + (RegMap sym args) (RegMap sym args') +overrideRegMap = lens _overrideRegMap (\o x -> o{ _overrideRegMap = x }) + +------------------------------------------------------------------------ +-- SimFrame + +{- An alternate idea we could try to save a few indirections... +type family SimFrame sym ext l args :: * where + SimFrame sym ext (OverrideLang ret) ('Just args) = OverrideFrame sym ret args + SimFrame sym ext (CrucibleLang blocks ret) ('Just args) = CallFrame sym ext blocks ret args + SimFrame sym ext (CrucibleLang blocks ret) ('Nothing) = RegEntry sym ret +-} + +type family FrameRetType (f :: Type) :: CrucibleType where + FrameRetType (CrucibleLang b r) = r + FrameRetType (OverrideLang r) = r + +data SimFrame sym ext l (args :: Maybe (Ctx CrucibleType)) where + -- | Custom code to execute, typically for "overrides" + OF :: !(OverrideFrame sym ret args) + -> SimFrame sym ext (OverrideLang ret) ('Just args) + + -- | We are executing some Crucible instructions + MF :: !(CallFrame sym ext blocks ret args) + -> SimFrame sym ext (CrucibleLang blocks ret) ('Just args) + + -- | We should return this value. + RF :: !FunctionName {- Function we are returning from -} + -> !(RegEntry sym (FrameRetType f)) + -> SimFrame sym ext f 'Nothing + + +overrideSimFrame :: Lens (SimFrame sym ext (OverrideLang r) ('Just args)) + (SimFrame sym ext (OverrideLang r') ('Just args')) + (OverrideFrame sym r args) + (OverrideFrame sym r' args') +overrideSimFrame f (OF g) = OF <$> f g + +crucibleSimFrame :: Lens (SimFrame sym ext (CrucibleLang blocks r) ('Just args)) + (SimFrame sym ext (CrucibleLang blocks' r') ('Just args')) + (CallFrame sym ext blocks r args) + (CallFrame sym ext blocks' r' args') +crucibleSimFrame f (MF c) = MF <$> f c + + +fromCallFrame :: SimFrame sym ext (CrucibleLang b r) ('Just a) + -> CallFrame sym ext b r a +fromCallFrame (MF x) = x + +fromReturnFrame :: SimFrame sym ext f 'Nothing + -> RegEntry sym (FrameRetType f) +fromReturnFrame (RF _ x) = x + +frameFunctionName :: Getter (SimFrame sym ext f a) FunctionName +frameFunctionName = to $ \case + OF f -> f^.override + MF f -> case frameHandle f of SomeHandle h -> handleName h + RF n _ -> n diff --git a/src/Lang/Crucible/Simulator/EvalStmt.hs b/src/Lang/Crucible/Simulator/EvalStmt.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/EvalStmt.hs @@ -0,0 +1,694 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.EvalStmt +-- Description : Provides functions for evaluating statements. +-- Copyright : (c) Galois, Inc 2013-2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides functions for evaluating Crucible statements. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.EvalStmt + ( -- * High-level evaluation + singleStepCrucible + , executeCrucible + , ExecutionFeature(..) + , GenericExecutionFeature(..) + , ExecutionFeatureResult(..) + , genericToExecutionFeature + , timeoutFeature + + -- * Lower-level evaluation operations + , dispatchExecState + , advanceCrucibleState + , evalReg + , evalReg' + , evalExpr + , evalArgs + , evalJumpTarget + , evalSwitchTarget + , stepStmt + , stepTerm + , stepBasicBlock + , readRef + , alterRef + ) where + +import qualified Control.Exception as Ex +import Control.Lens +import Control.Monad (foldM, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT(..), withReaderT) +import Data.Maybe (fromMaybe) +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.TraversableFC +import qualified Data.Text as Text +import Data.Time.Clock +import System.IO +import System.IO.Error as Ex +import Prettyprinter + +import What4.Config +import What4.Interface +import What4.InterpretedFloatingPoint (freshFloatConstant) +import What4.Partial +import What4.ProgramLoc + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Extension +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.Evaluation +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.Intrinsics (IntrinsicTypes) +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Operations +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Utils.MuxTree + + +-- | Retrieve the value of a register. +evalReg :: + Monad m => + Reg ctx tp -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) m (RegValue sym tp) +evalReg r = (`regVal` r) <$> view (stateCrucibleFrame.frameRegs) + +-- | Retrieve the value of a register, returning a 'RegEntry'. +evalReg' :: + Monad m => + Reg ctx tp -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) m (RegEntry sym tp) +evalReg' r = (`regVal'` r) <$> view (stateCrucibleFrame.frameRegs) + + +evalLogFn :: + Int {- current verbosity -} -> + CrucibleState p sym ext rtp blocks r ctx -> + Int {- verbosity level of the message -} -> + String -> + IO () +evalLogFn verb s n msg = do + let h = s^.stateContext.to printHandle + if verb >= n then + do hPutStr h msg + hFlush h + else + return () + +-- | Evaluate an expression. +evalExpr :: forall p sym ext ctx tp rtp blocks r. + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ current verbosity -} -> + Expr ext ctx tp -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) IO (RegValue sym tp) +evalExpr verb (App a) = ReaderT $ \s -> + do let iteFns = s^.stateIntrinsicTypes + let simCtx = s^.stateContext + let logFn = evalLogFn verb s + r <- withBackend simCtx $ \bak -> + evalApp bak iteFns logFn + (extensionEval (extensionImpl (s^.stateContext)) bak iteFns logFn s) + (\r -> runReaderT (evalReg r) s) + a + return $! r + +evalArgs' :: forall sym ctx args. + RegMap sym ctx -> + Ctx.Assignment (Reg ctx) args -> + RegMap sym args +evalArgs' m0 args = RegMap (fmapFC (getEntry m0) args) + where getEntry :: RegMap sym ctx -> Reg ctx tp -> RegEntry sym tp + getEntry (RegMap m) r = m Ctx.! regIndex r +{-# NOINLINE evalArgs' #-} + +-- | Evaluate the actual arguments for a function call or block transfer. +evalArgs :: + Monad m => + Ctx.Assignment (Reg ctx) args -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) m (RegMap sym args) +evalArgs args = ReaderT $ \s -> return $! evalArgs' (s^.stateCrucibleFrame.frameRegs) args +{-# INLINE evalArgs #-} + +-- | Resolve the arguments for a jump. +evalJumpTarget :: + (IsSymInterface sym, Monad m) => + JumpTarget blocks ctx {- ^ Jump target to evaluate -} -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) m (ResolvedJump sym blocks) +evalJumpTarget (JumpTarget tgt _ a) = ResolvedJump tgt <$> evalArgs a + +-- | Resolve the arguments for a switch target. +evalSwitchTarget :: + (IsSymInterface sym, Monad m) => + SwitchTarget blocks ctx tp {- ^ Switch target to evaluate -} -> + RegEntry sym tp {- ^ Value inside the variant -} -> + ReaderT (CrucibleState p sym ext rtp blocks r ctx) m (ResolvedJump sym blocks) +evalSwitchTarget (SwitchTarget tgt _tp a) x = + do xs <- evalArgs a + return (ResolvedJump tgt (assignReg' x xs)) + +-- | Update a reference cell with a new value. Writing an unassigned +-- value resets the reference cell to an uninitialized state. +alterRef :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + TypeRepr tp -> + MuxTree sym (RefCell tp) -> + PartExpr (Pred sym) (RegValue sym tp) -> + SymGlobalState sym -> + IO (SymGlobalState sym) +alterRef sym iTypes tpr rs newv globs = foldM upd globs (viewMuxTree rs) + where + f p a b = liftIO $ muxRegForType sym iTypes tpr p a b + + upd gs (r,p) = + do let oldv = lookupRef r globs + z <- mergePartial sym f p newv oldv + return (gs & updateRef r z) + +-- | Read from a reference cell. +readRef :: + IsSymBackend sym bak => + bak -> + IntrinsicTypes sym -> + TypeRepr tp -> + MuxTree sym (RefCell tp) -> + SymGlobalState sym -> + IO (RegValue sym tp) +readRef bak iTypes tpr rs globs = + do let sym = backendGetSym bak + let vs = map (\(r,p) -> (p,lookupRef r globs)) (viewMuxTree rs) + let f p a b = liftIO $ muxRegForType sym iTypes tpr p a b + pv <- mergePartials sym f vs + let msg = ReadBeforeWriteSimError "Attempted to read uninitialized reference cell" + readPartExpr bak pv msg + + +-- | Evaluation operation for evaluating a single straight-line +-- statement of the Crucible evaluator. +-- +-- This is allowed to throw user exceptions or 'SimError'. +stepStmt :: forall p sym ext rtp blocks r ctx ctx'. + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ Current verbosity -} -> + Stmt ext ctx ctx' {- ^ Statement to evaluate -} -> + StmtSeq ext blocks r ctx' {- ^ Remaining statements in the block -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) +stepStmt verb stmt rest = + do ctx <- view stateContext + let sym = ctx^.ctxSymInterface + let iTypes = ctxIntrinsicTypes ctx + globals <- view (stateTree.actFrame.gpGlobals) + + let continueWith :: forall rtp' blocks' r' c f a. + (SimState p sym ext rtp' f a -> SimState p sym ext rtp' (CrucibleLang blocks' r') ('Just c)) -> + ExecCont p sym ext rtp' f a + continueWith f = withReaderT f (checkConsTerm verb) + + withBackend ctx $ \bak -> + case stmt of + NewRefCell tpr x -> + do let halloc = simHandleAllocator ctx + v <- evalReg x + r <- liftIO $ freshRefCell halloc tpr + continueWith $ + (stateTree . actFrame . gpGlobals %~ insertRef sym r v) . + (stateCrucibleFrame %~ extendFrame (ReferenceRepr tpr) (toMuxTree sym r) rest) + + NewEmptyRefCell tpr -> + do let halloc = simHandleAllocator ctx + r <- liftIO $ freshRefCell halloc tpr + continueWith $ + stateCrucibleFrame %~ extendFrame (ReferenceRepr tpr) (toMuxTree sym r) rest + + ReadRefCell x -> + do RegEntry (ReferenceRepr tpr) rs <- evalReg' x + v <- liftIO $ readRef bak iTypes tpr rs globals + continueWith $ + stateCrucibleFrame %~ extendFrame tpr v rest + + WriteRefCell x y -> + do RegEntry (ReferenceRepr tpr) rs <- evalReg' x + newv <- justPartExpr sym <$> evalReg y + globals' <- liftIO $ alterRef sym iTypes tpr rs newv globals + continueWith $ + (stateTree . actFrame . gpGlobals .~ globals') . + (stateCrucibleFrame . frameStmts .~ rest) + + DropRefCell x -> + do RegEntry (ReferenceRepr tpr) rs <- evalReg' x + globals' <- liftIO $ alterRef sym iTypes tpr rs Unassigned globals + continueWith $ + (stateTree . actFrame . gpGlobals .~ globals') . + (stateCrucibleFrame . frameStmts .~ rest) + + ReadGlobal global_var -> do + case lookupGlobal global_var globals of + Nothing -> + do let msg = ReadBeforeWriteSimError $ "Attempt to read undefined global " ++ show global_var + liftIO $ addFailedAssertion bak msg + Just v -> + continueWith $ + (stateCrucibleFrame %~ extendFrame (globalType global_var) v rest) + + WriteGlobal global_var local_reg -> + do v <- evalReg local_reg + continueWith $ + (stateTree . actFrame . gpGlobals %~ insertGlobal global_var v) . + (stateCrucibleFrame . frameStmts .~ rest) + + FreshConstant bt mnm -> + do let nm = fromMaybe emptySymbol mnm + v <- liftIO $ freshConstant sym nm bt + continueWith $ stateCrucibleFrame %~ extendFrame (baseToType bt) v rest + + FreshFloat fi mnm -> + do let nm = fromMaybe emptySymbol mnm + v <- liftIO $ freshFloatConstant sym nm fi + continueWith $ stateCrucibleFrame %~ extendFrame (FloatRepr fi) v rest + + FreshNat mnm -> + do let nm = fromMaybe emptySymbol mnm + v <- liftIO $ freshNat sym nm + continueWith $ stateCrucibleFrame %~ extendFrame NatRepr v rest + + SetReg tp e -> + do v <- evalExpr verb e + continueWith $ stateCrucibleFrame %~ extendFrame tp v rest + + ExtendAssign estmt -> do + do let tp = appType estmt + estmt' <- traverseFC evalReg' estmt + ReaderT $ \s -> + do (v,s') <- liftIO $ extensionExec (extensionImpl ctx) estmt' s + runReaderT + (continueWith $ stateCrucibleFrame %~ extendFrame tp v rest) + s' + + CallHandle ret_type fnExpr _types arg_exprs -> + do hndl <- evalReg fnExpr + args <- evalArgs arg_exprs + loc <- liftIO $ getCurrentProgramLoc sym + callFunction hndl args (ReturnToCrucible ret_type rest) loc + + Print e -> + do msg <- evalReg e + let msg' = case asString msg of + Just (UnicodeLiteral txt) -> Text.unpack txt + _ -> show (printSymExpr msg) + liftIO $ do + let h = printHandle ctx + hPutStr h msg' + hFlush h + continueWith (stateCrucibleFrame . frameStmts .~ rest) + + Assert c_expr msg_expr -> + do c <- evalReg c_expr + msg <- evalReg msg_expr + let err = case asString msg of + Just (UnicodeLiteral txt) -> AssertFailureSimError (Text.unpack txt) "" + _ -> AssertFailureSimError "Symbolic message" (show (printSymExpr msg)) + liftIO $ assert bak c err + continueWith (stateCrucibleFrame . frameStmts .~ rest) + + Assume c_expr msg_expr -> + do c <- evalReg c_expr + msg <- evalReg msg_expr + let msg' = case asString msg of + Just (UnicodeLiteral txt) -> Text.unpack txt + _ -> show (printSymExpr msg) + liftIO $ + do loc <- getCurrentProgramLoc sym + addAssumption bak (GenericAssumption loc msg' c) + + continueWith (stateCrucibleFrame . frameStmts .~ rest) + + +{-# INLINABLE stepTerm #-} + +-- | Evaluation operation for evaluating a single block-terminator +-- statement of the Crucible evaluator. +-- +-- This is allowed to throw user exceptions or 'SimError'. +stepTerm :: forall p sym ext rtp blocks r ctx. + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ Verbosity -} -> + TermStmt blocks r ctx {- ^ Terminating statement to evaluate -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) + +stepTerm _ (Jump tgt) = + jumpToBlock =<< evalJumpTarget tgt + +stepTerm _ (Return arg) = + returnValue =<< evalReg' arg + +stepTerm _ (Br c x y) = + do x_jump <- evalJumpTarget x + y_jump <- evalJumpTarget y + p <- evalReg c + conditionalBranch p x_jump y_jump + +stepTerm _ (MaybeBranch tp e j n) = + do evalReg e >>= \case + Unassigned -> jumpToBlock =<< evalJumpTarget n + PE p v -> + do j_jump <- evalSwitchTarget j (RegEntry tp v) + n_jump <- evalJumpTarget n + conditionalBranch p j_jump n_jump + +stepTerm _ (VariantElim ctx e cases) = + do vs <- evalReg e + jmps <- ctx & Ctx.traverseAndCollect (\i tp -> + case vs Ctx.! i of + VB Unassigned -> + return [] + VB (PE p v) -> + do jmp <- evalSwitchTarget (cases Ctx.! i) (RegEntry tp v) + return [(p,jmp)]) + + variantCases jmps + +-- When we make a tail call, we first try to unwind our calling context +-- and replace the currently-active frame with the frame of the new called +-- function. However, this is only successful if there are no pending +-- symbolic merges. +-- +-- If there _are_ pending merges we instead treat the tail call as normal +-- call-then-return sequence, pushing a new call frame on the top of our +-- current context (rather than replacing it). The TailReturnToCrucible +-- return handler tells the simulator to immediately invoke another return +-- in the caller, which is still present on the stack in this scenario. +stepTerm _ (TailCall fnExpr _types arg_exprs) = + do cl <- evalReg fnExpr + args <- evalArgs arg_exprs + ctx <- view (stateTree.actContext) + sym <- view stateSymInterface + loc <- liftIO $ getCurrentProgramLoc sym + case unwindContext ctx of + Just vfv -> tailCallFunction cl args vfv loc + Nothing -> callFunction cl args TailReturnToCrucible loc + +stepTerm _ (ErrorStmt msg) = + do msg' <- evalReg msg + simCtx <- view stateContext + withBackend simCtx $ \bak -> liftIO $ + case asString msg' of + Just (UnicodeLiteral txt) -> + addFailedAssertion bak + $ GenericSimError $ Text.unpack txt + Nothing -> addFailedAssertion bak + $ GenericSimError $ show (printSymExpr msg') + + +-- | Checks whether the StmtSeq is a Cons or a Term, +-- to give callers another chance to jump into Crucible's control flow +checkConsTerm :: + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ Current verbosity -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) +checkConsTerm verb = + do cf <- view stateCrucibleFrame + + case cf^.frameStmts of + ConsStmt _ _ _ -> stepBasicBlock verb + TermStmt _ _ -> continue (RunBlockEnd (cf^.frameBlockID)) + +-- | Main evaluation operation for running a single step of +-- basic block evaluation. +-- +-- This is allowed to throw user exceptions or 'SimError'. +stepBasicBlock :: + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ Current verbosity -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) +stepBasicBlock verb = + do ctx <- view stateContext + let sym = ctx^.ctxSymInterface + let h = printHandle ctx + cf <- view stateCrucibleFrame + + case cf^.frameStmts of + ConsStmt pl stmt rest -> + do liftIO $ + do setCurrentProgramLoc sym pl + let sz = regMapSize (cf^.frameRegs) + when (verb >= 4) $ ppStmtAndLoc h (frameHandle cf) pl (ppStmt sz stmt) + stepStmt verb stmt rest + + TermStmt pl termStmt -> do + do liftIO $ + do setCurrentProgramLoc sym pl + when (verb >= 4) $ ppStmtAndLoc h (frameHandle cf) pl (pretty termStmt) + stepTerm verb termStmt + +ppStmtAndLoc :: Handle -> SomeHandle -> ProgramLoc -> Doc ann -> IO () +ppStmtAndLoc h sh pl stmt = do + hPrint h $ + vcat [ viaShow sh <> pretty ':' + , indent 2 (stmt <+> pretty "%" <+> ppNoFileName (plSourceLoc pl)) ] + hFlush h + +performStateRun :: + (IsSymInterface sym, IsSyntaxExtension ext) => + RunningStateInfo blocks ctx -> + Int {- ^ Current verbosity -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) +performStateRun info verb = case info of + RunPostBranchMerge bid -> continue (RunBlockStart bid) + _ -> stepBasicBlock verb + + +---------------------------------------------------------------------- +-- ExecState manipulations + + +-- | Given an 'ExecState', examine it and either enter the continuation +-- for final results, or construct the appropriate 'ExecCont' for +-- continuing the computation and enter the provided intermediate continuation. +dispatchExecState :: + (IsSymInterface sym, IsSyntaxExtension ext) => + IO Int {- ^ Action to query the current verbosity -} -> + ExecState p sym ext rtp {- ^ Current execution state of the simulator -} -> + (ExecResult p sym ext rtp -> IO z) {- ^ Final continuation for results -} -> + (forall f a. ExecCont p sym ext rtp f a -> SimState p sym ext rtp f a -> IO z) + {- ^ Intermediate continuation for running states -} -> + IO z +dispatchExecState getVerb exst kresult k = + case exst of + ResultState res -> + kresult res + + InitialState simctx globals ah ret cont -> + do st <- initSimState simctx globals ah ret + k cont st + + AbortState rsn st -> + let (AH handler) = st^.abortHandler in + k (handler rsn) st + + OverrideState ovr st -> + k (overrideHandler ovr) st + + SymbolicBranchState p a_frame o_frame tgt st -> + k (performIntraFrameSplit p a_frame o_frame tgt) st + + ControlTransferState resumption st -> + k (performControlTransfer resumption) st + + BranchMergeState tgt st -> + k (performIntraFrameMerge tgt) st + + UnwindCallState vfv ar st -> + k (resumeValueFromValueAbort vfv ar) st + + CallState retHandler frm st -> + k (performFunctionCall retHandler frm) st + + TailCallState vfv frm st -> + k (performTailCall vfv frm) st + + ReturnState fnm vfv ret st -> + k (performReturn fnm vfv ret) st + + RunningState info st -> + do v <- getVerb + k (performStateRun info v) st +{-# INLINE dispatchExecState #-} + + +-- | Run the given @ExecCont@ on the given @SimState@, +-- being careful to catch any simulator abort exceptions +-- that are thrown and dispatch them to the abort handler. +advanceCrucibleState :: + (IsSymInterface sym, IsSyntaxExtension ext) => + ExecCont p sym ext rtp f a -> + SimState p sym ext rtp f a -> + IO (ExecState p sym ext rtp) +advanceCrucibleState m st = + Ex.catches (runReaderT m st) + [ Ex.Handler $ \(e::AbortExecReason) -> + runAbortHandler e st + , Ex.Handler $ \(e::Ex.IOException) -> + if Ex.isUserError e then + runGenericErrorHandler (Ex.ioeGetErrorString e) st + else + Ex.throwIO e + ] + + +-- | Run a single step of the Crucible symbolic simulator. +singleStepCrucible :: + (IsSymInterface sym, IsSyntaxExtension ext) => + Int {- ^ Current verbosity -} -> + ExecState p sym ext rtp -> + IO (ExecState p sym ext rtp) +singleStepCrucible verb exst = + dispatchExecState + (return verb) + exst + (return . ResultState) + advanceCrucibleState + + +-- | This datatype indicates the possible results that an execution feature +-- can have. +data ExecutionFeatureResult p sym ext rtp where + -- | This execution feature result indicates that no state changes were + -- made. + ExecutionFeatureNoChange :: ExecutionFeatureResult p sym ext rtp + + -- | This execution feature indicates that the state was modified but + -- not changed in an "essential" way. For example, internal bookkeeping + -- datastructures for the execution feature might be modified, but the + -- state is not transitioned to a fundamentally different state. + -- + -- When this result is returned, later execution features in the + -- installed stack will be executed, until the main simulator loop + -- is encountered. Contrast with the \"new state\" result. + ExecutionFeatureModifiedState :: + ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp + + -- | This execution feature result indicates that the state was modified + -- in an essential way that transforms it into new state altogether. + -- When this result is returned, it preempts any later execution + -- features and the main simulator loop and instead returns to the head + -- of the execution feature stack. + -- + -- NOTE: In particular, the execution feature will encounter the + -- state again before the simulator loop. It is therefore very + -- important that the execution feature be prepared to immediately + -- encounter the same state again and make significant execution + -- progress on it, or ignore it so it makes it to the main simulator + -- loop. Otherwise, the execution feature will loop back to itself + -- infinitely, starving out useful work. + ExecutionFeatureNewState :: + ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp + + +-- | An execution feature represents a computation that is allowed to intercept +-- the processing of execution states to perform additional processing at +-- each intermediate state. A list of execution features is accepted by +-- `executeCrucible`. After each step of the simulator, the execution features +-- are consulted, each in turn. After all the execution features have run, +-- the main simulator code is executed to advance the simulator one step. +-- +-- If an execution feature wishes to make changes to the execution +-- state before further execution happens, the return value can be +-- used to return a modified state. If this happens, the current +-- stack of execution features is abandoned and a fresh step starts +-- over immediately from the top of the execution features. In +-- essence, each execution feature can preempt all following +-- execution features and the main simulator loop. In other words, +-- the main simulator only gets reached if every execution feature +-- returns @Nothing@. It is important, therefore, that execution +-- features make only a bounded number of modification in a row, or +-- the main simulator loop will be starved out. +newtype ExecutionFeature p sym ext rtp = + ExecutionFeature + { runExecutionFeature :: ExecState p sym ext rtp -> IO (ExecutionFeatureResult p sym ext rtp) + } + +-- | A generic execution feature is an execution feature that is +-- agnostic to the execution environment, and is therefore +-- polymorphic over the @p@, @ext@ and @rtp@ variables. +newtype GenericExecutionFeature sym = + GenericExecutionFeature + { runGenericExecutionFeature :: forall p ext rtp. + (IsSymInterface sym, IsSyntaxExtension ext) => + ExecState p sym ext rtp -> IO (ExecutionFeatureResult p sym ext rtp) + } + +genericToExecutionFeature :: + (IsSymInterface sym, IsSyntaxExtension ext) => + GenericExecutionFeature sym -> ExecutionFeature p sym ext rtp +genericToExecutionFeature (GenericExecutionFeature f) = ExecutionFeature f + + +-- | Given a 'SimState' and an execution continuation, +-- apply the continuation and execute the resulting +-- computation until completion. +-- +-- This function is responsible for catching +-- 'AbortExecReason' exceptions and 'UserError' +-- exceptions and invoking the 'errorHandler' +-- contained in the state. +executeCrucible :: forall p sym ext rtp. + ( IsSymInterface sym + , IsSyntaxExtension ext + ) => + [ ExecutionFeature p sym ext rtp ] {- ^ Execution features to install -} -> + ExecState p sym ext rtp {- ^ Execution state to begin executing -} -> + IO (ExecResult p sym ext rtp) +executeCrucible execFeatures exst0 = + do let cfg = getConfiguration . view ctxSymInterface . execStateContext $ exst0 + verbOpt <- getOptionSetting verbosity cfg + + let loop exst = + dispatchExecState + (fromInteger <$> getOpt verbOpt) + exst + return + (\m st -> knext =<< advanceCrucibleState m st) + + applyExecutionFeature feat m = \exst -> + runExecutionFeature feat exst >>= \case + ExecutionFeatureNoChange -> m exst + ExecutionFeatureModifiedState exst' -> m exst' + ExecutionFeatureNewState exst' -> knext exst' + + knext = foldr applyExecutionFeature loop execFeatures + + knext exst0 + + +-- | This feature will terminate the execution of a crucible simulator +-- with a @TimeoutResult@ after a given interval of wall-clock time +-- has elapsed. +timeoutFeature :: + NominalDiffTime -> + IO (GenericExecutionFeature sym) +timeoutFeature timeout = + do startTime <- getCurrentTime + let deadline = addUTCTime timeout startTime + return $ GenericExecutionFeature $ \exst -> + case exst of + ResultState _ -> return ExecutionFeatureNoChange + _ -> + do now <- getCurrentTime + if deadline >= now then + return ExecutionFeatureNoChange + else + return (ExecutionFeatureNewState (ResultState (TimeoutResult exst))) diff --git a/src/Lang/Crucible/Simulator/Evaluation.hs b/src/Lang/Crucible/Simulator/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/Evaluation.hs @@ -0,0 +1,1006 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.Evaluation +-- Description : Evaluation functions for Crucible core expressions +-- Copyright : (c) Galois, Inc 2014-2016 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides operations evaluating Crucible expressions. +------------------------------------------------------------------------ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +module Lang.Crucible.Simulator.Evaluation + ( EvalAppFunc + , evalApp + , selectedIndices + , indexSymbolic + , integerAsChar + , complexRealAsChar + , indexVectorWithSymNat + , adjustVectorWithSymNat + , updateVectorWithSymNat + ) where + +import Prelude hiding (pred) + +import qualified Control.Exception as Ex +import Control.Lens +import Control.Monad +import qualified Data.BitVector.Sized as BV +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as Text +import qualified Data.Vector as V +import Data.Word +import Numeric ( showHex ) +import Numeric.Natural +import GHC.Stack + +import Data.Parameterized.Classes +import Data.Parameterized.Context as Ctx +import Data.Parameterized.TraversableFC + +import What4.Interface +import What4.InterpretedFloatingPoint +import What4.Partial (pattern PE, pattern Unassigned, joinMaybePE) +import What4.Utils.Complex +import What4.WordMap + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Expr +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Simulator.SymSequence +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- Utilities + + +-- | Given a list of Booleans l, @selectedIndices@ returns the indices of +-- true values in @l@. +selectedIndices :: [Bool] -> [Natural] +selectedIndices l = catMaybes $ Prelude.zipWith selectIndex l [1..] + where selectIndex True i = Just i + selectIndex False _ = Nothing + +------------------------------------------------------------------------ +-- Coercion functions + +integerAsChar :: Integer -> Word16 +integerAsChar i = fromInteger ((i `max` 0) `min` (2^(16::Int)-1)) + +complexRealAsChar :: (MonadFail m, IsExpr val) + => val BaseComplexType + -> m Word16 +complexRealAsChar v = do + case cplxExprAsRational v of + -- Check number is printable. + Just r | otherwise -> return (integerAsChar (floor r)) + Nothing -> fail "Symbolic value cannot be interpreted as a character." + -- XXX: Should this be a panic? + -- XXX: We should move this to crucible-matlab + +------------------------------------------------------------------------ +-- Evaluating expressions + + +-- | Helper method for implementing 'indexSymbolic' +indexSymbolic' :: IsSymBackend sym bak + => bak + -> (Pred sym -> a -> a -> IO a) + -- ^ Function for merging valeus + -> ([Natural] -> IO a) -- ^ Concrete index function. + -> [Natural] -- ^ Values of processed indices (in reverse order) + -> [(Natural,Natural)] -- ^ Bounds on remaining indices. + -> [SymNat sym] -- ^ Remaining indices. + -> IO a +indexSymbolic' _ _ f p [] _ = f (reverse p) +indexSymbolic' _ _ f p _ [] = f (reverse p) +indexSymbolic' bak iteFn f p ((l,h):nl) (si:il) = do + let subIndex idx = indexSymbolic' bak iteFn f (idx:p) nl il + case asNat si of + Just i + | l <= i && i <= h -> subIndex i + | otherwise -> + addFailedAssertion bak (AssertFailureSimError msg details) + where msg = "Index outside matrix dimensions." ++ show (l,i,h) + details = unwords ["Index", show i, "is outside of range", show (l, h)] + Nothing -> + do let sym = backendGetSym bak + ensureInRange bak l h si "Index outside matrix dimensions." + let predFn i = natEq sym si =<< natLit sym i + muxRange predFn iteFn subIndex l h + + +ensureInRange :: + IsSymBackend sym bak => + bak -> + Natural -> + Natural -> + SymNat sym -> + String -> + IO () +ensureInRange bak l h si msg = + do let sym = backendGetSym bak + l_sym <- natLit sym l + h_sym <- natLit sym h + inRange <- join $ andPred sym <$> natLe sym l_sym si <*> natLe sym si h_sym + assert bak inRange (AssertFailureSimError msg details) + where details = unwords ["Range is", show (l, h)] + + + +-- | Lookup a value in an array that may be at a symbolic offset. +-- +-- This function takes a list of symbolic indices as natural numbers +-- along with a pair of lower and upper bounds for each index. +-- It assumes that the indices are all in range. +indexSymbolic :: IsSymBackend sym bak + => bak + -> (Pred sym -> a -> a -> IO a) + -- ^ Function for combining results together. + -> ([Natural] -> IO a) -- ^ Concrete index function. + -> [(Natural,Natural)] -- ^ High and low bounds at the indices. + -> [SymNat sym] + -> IO a +indexSymbolic sym iteFn f = indexSymbolic' sym iteFn f [] + +-- | Evaluate an indexTermterm to an index value. +evalBase :: IsSymInterface sym => + sym + -> (forall utp . f utp -> IO (RegValue sym utp)) + -> BaseTerm f vtp + -> IO (SymExpr sym vtp) +evalBase _ evalSub (BaseTerm _tp e) = evalSub e + +-- | Get value stored in vector at a symbolic index. +indexVectorWithSymNat :: IsSymBackend sym bak + => bak + -> (Pred sym -> a -> a -> IO a) + -- ^ Ite function + -> V.Vector a + -> SymNat sym + -> IO a +indexVectorWithSymNat bak iteFn v si = + Ex.assert (n > 0) $ + case asNat si of + Just i | 0 <= i && i < n -> return (v V.! fromIntegral i) + | otherwise -> addFailedAssertion bak (AssertFailureSimError msg details) + Nothing -> + do let sym = backendGetSym bak + let predFn i = natEq sym si =<< natLit sym i + let getElt i = return (v V.! fromIntegral i) + ensureInRange bak 0 (n - 1) si msg + muxRange predFn iteFn getElt 0 (n - 1) + where + n = fromIntegral (V.length v) + msg = "Vector index out of range" + details = unwords ["Range is", show (0 :: Natural, n)] + + + +-- | Update a vector at a given natural number index. +updateVectorWithSymNat :: IsSymBackend sym bak + => bak + -- ^ Symbolic backend + -> (Pred sym -> a -> a -> IO a) + -- ^ Ite function + -> V.Vector a + -- ^ Vector to update + -> SymNat sym + -- ^ Index to update + -> a + -- ^ New value to assign + -> IO (V.Vector a) +updateVectorWithSymNat bak iteFn v si new_val = do + adjustVectorWithSymNat bak iteFn v si (\_ -> return new_val) + +-- | Update a vector at a given natural number index. +adjustVectorWithSymNat :: IsSymBackend sym bak + => bak + -- ^ Symbolic backend + -> (Pred sym -> a -> a -> IO a) + -- ^ Ite function + -> V.Vector a + -- ^ Vector to update + -> SymNat sym + -- ^ Index to update + -> (a -> IO a) + -- ^ Adjustment function to apply + -> IO (V.Vector a) +adjustVectorWithSymNat bak iteFn v si adj = + case asNat si of + Just i + + | i < fromIntegral n -> + do new_val <- adj (v V.! fromIntegral i) + return $ v V.// [(fromIntegral i, new_val)] + + | otherwise -> + addFailedAssertion bak $ AssertFailureSimError msg (details i) + + Nothing -> + do ensureInRange bak 0 (fromIntegral (n-1)) si msg + V.generateM n setFn + where + setFn j = + do let sym = backendGetSym bak + -- Compare si and j. + c <- natEq sym si =<< natLit sym (fromIntegral j) + -- Select old value or new value + case asConstantPred c of + Just True -> adj (v V.! j) + Just False -> return (v V.! j) + Nothing -> + do new_val <- adj (v V.! j) + iteFn c new_val (v V.! j) + + where + n = V.length v + msg = "Illegal vector index" + details i = "Illegal index " ++ show i ++ "given to updateVectorWithSymNat" + +type EvalAppFunc sym app = forall f. + (forall tp. f tp -> IO (RegValue sym tp)) -> + (forall tp. app f tp -> IO (RegValue sym tp)) + +{-# INLINE evalApp #-} +-- | Evaluate the application. +evalApp :: forall sym bak ext. + IsSymBackend sym bak + => bak + -> IntrinsicTypes sym + -> (Int -> String -> IO ()) + -- ^ Function for logging messages. + -> EvalAppFunc sym (ExprExtension ext) + -> EvalAppFunc sym (App ext) +evalApp bak itefns _logFn evalExt (evalSub :: forall tp. f tp -> IO (RegValue sym tp)) a0 = do + let sym = backendGetSym bak + case a0 of + + BaseIsEq tp xe ye -> do + x <- evalBase sym evalSub (BaseTerm tp xe) + y <- evalBase sym evalSub (BaseTerm tp ye) + isEq sym x y + + BaseIte tp ce xe ye -> do + c <- evalSub ce + case asConstantPred c of + Just True -> evalSub xe + Just False -> evalSub ye + Nothing -> do + x <- evalBase sym evalSub (BaseTerm tp xe) + y <- evalBase sym evalSub (BaseTerm tp ye) + baseTypeIte sym c x y + + ---------------------------------------------------------------------- + ExtensionApp x -> evalExt evalSub x + + ---------------------------------------------------------------------- + -- () + + EmptyApp -> return () + + ---------------------------------------------------------------------- + -- Any + + PackAny tp x -> do + xv <- evalSub x + return (AnyValue tp xv) + + UnpackAny tp x -> do + xv <- evalSub x + case xv of + AnyValue tpv v + | Just Refl <- testEquality tp tpv -> + return $! PE (truePred sym) v + | otherwise -> + return Unassigned + + ---------------------------------------------------------------------- + -- Bool + + BoolLit b -> return $ backendPred sym b + Not x -> do + r <- evalSub x + notPred sym r + And x y -> do + xv <- evalSub x + yv <- evalSub y + andPred sym xv yv + Or x y -> do + xv <- evalSub x + yv <- evalSub y + orPred sym xv yv + BoolXor x y -> do + xv <- evalSub x + yv <- evalSub y + xorPred sym xv yv + + ---------------------------------------------------------------------- + -- Nat + + NatLit n -> natLit sym n + NatIte pe xe ye -> do + p <- evalSub pe + x <- evalSub xe + y <- evalSub ye + natIte sym p x y + NatEq xe ye -> do + x <- evalSub xe + y <- evalSub ye + natEq sym x y + NatLt xe ye -> do + x <- evalSub xe + y <- evalSub ye + natLt sym x y + NatLe xe ye -> do + x <- evalSub xe + y <- evalSub ye + natLe sym x y + NatAdd xe ye -> do + x <- evalSub xe + y <- evalSub ye + natAdd sym x y + NatSub xe ye -> do + x <- evalSub xe + y <- evalSub ye + natSub sym x y + NatMul xe ye -> do + x <- evalSub xe + y <- evalSub ye + natMul sym x y + NatDiv xe ye -> do + x <- evalSub xe + y <- evalSub ye + natDiv sym x y + NatMod xe ye -> do + x <- evalSub xe + y <- evalSub ye + natMod sym x y + + ---------------------------------------------------------------------- + -- Int + + IntLit n -> intLit sym n + IntLe xe ye -> do + x <- evalSub xe + y <- evalSub ye + intLe sym x y + IntLt xe ye -> do + x <- evalSub xe + y <- evalSub ye + intLt sym x y + IntNeg xe -> do + x <- evalSub xe + intNeg sym x + IntAbs xe -> do + x <- evalSub xe + intAbs sym x + IntAdd xe ye -> do + x <- evalSub xe + y <- evalSub ye + intAdd sym x y + IntSub xe ye -> do + x <- evalSub xe + y <- evalSub ye + intSub sym x y + IntMul xe ye -> do + x <- evalSub xe + y <- evalSub ye + intMul sym x y + IntDiv xe ye -> do + x <- evalSub xe + y <- evalSub ye + intDiv sym x y + IntMod xe ye -> do + x <- evalSub xe + y <- evalSub ye + intMod sym x y + + -------------------------------------------------------------------- + -- Maybe + + JustValue _ e -> do + r <- evalSub e + return $! PE (truePred sym) r + NothingValue _ -> do + return Unassigned + FromJustValue _ maybe_expr msg_expr -> do + maybe_val <- evalSub maybe_expr + case maybe_val of + -- Special case to avoid forcing evaluation of msg. + PE (asConstantPred -> Just True) v -> return v + _ -> do + msg <- evalSub msg_expr + case asString msg of + Just (UnicodeLiteral msg') -> readPartExpr bak maybe_val (GenericSimError (Text.unpack msg')) + Nothing -> + addFailedAssertion bak $ + Unsupported callStack "Symbolic string in fromJustValue" + + ---------------------------------------------------------------------- + -- Recursive Types + + RollRecursive _ _ e -> RolledType <$> evalSub e + UnrollRecursive _ _ e -> unroll <$> evalSub e + + ---------------------------------------------------------------------- + -- Vector + + VectorLit _ v -> traverse evalSub v + VectorReplicate _ n_expr e_expr -> do + ne <- evalSub n_expr + case asNat ne of + Nothing -> addFailedAssertion bak $ + Unsupported callStack "vectors with symbolic length" + Just n -> do + e <- evalSub e_expr + return $ V.replicate (fromIntegral n) e + VectorIsEmpty r -> do + v <- evalSub r + return $ backendPred sym (V.null v) + VectorSize v_expr -> do + v <- evalSub v_expr + natLit sym (fromIntegral (V.length v)) + VectorGetEntry rtp v_expr i_expr -> do + v <- evalSub v_expr + i <- evalSub i_expr + indexVectorWithSymNat bak (muxRegForType sym itefns rtp) v i + VectorSetEntry rtp v_expr i_expr n_expr -> do + v <- evalSub v_expr + i <- evalSub i_expr + n <- evalSub n_expr + updateVectorWithSymNat bak (muxRegForType sym itefns rtp) v i n + VectorCons _ e_expr v_expr -> do + e <- evalSub e_expr + v <- evalSub v_expr + return $ V.cons e v + + -------------------------------------------------------------------- + -- Sequence + + SequenceNil _tpr -> nilSymSequence sym + SequenceCons _tpr x xs -> + join $ consSymSequence sym <$> evalSub x <*> evalSub xs + SequenceAppend _tpr xs ys -> + join $ appendSymSequence sym <$> evalSub xs <*> evalSub ys + SequenceIsNil _tpr xs -> + isNilSymSequence sym =<< evalSub xs + SequenceLength _tpr xs -> + lengthSymSequence sym =<< evalSub xs + SequenceHead tpr xs -> + headSymSequence sym (muxRegForType sym itefns tpr) =<< evalSub xs + SequenceTail _tpr xs -> + tailSymSequence sym =<< evalSub xs + SequenceUncons tpr xs -> + do xs' <- evalSub xs + mu <- unconsSymSequence sym (muxRegForType sym itefns tpr) xs' + traverse (\ (h,tl) -> pure (Ctx.Empty Ctx.:> RV h Ctx.:> RV tl)) mu + + -------------------------------------------------------------------- + -- Symbolic Arrays + + SymArrayLookup _ a i -> do + join $ arrayLookup sym <$> evalSub a <*> traverseFC (evalBase sym evalSub) i + + SymArrayUpdate _ a i v -> do + join $ arrayUpdate sym + <$> evalSub a + <*> traverseFC (evalBase sym evalSub) i + <*> evalSub v + + ---------------------------------------------------------------------- + -- Handle + + HandleLit h -> return (HandleFnVal h) + + Closure _ _ h_expr tp v_expr -> do + h <- evalSub h_expr + v <- evalSub v_expr + return $! ClosureFnVal h tp v + + ---------------------------------------------------------------------- + -- RealVal + + RationalLit d -> realLit sym d + RealNeg xe -> do + x <- evalSub xe + realNeg sym x + RealAdd xe ye -> do + x <- evalSub xe + y <- evalSub ye + realAdd sym x y + RealSub xe ye -> do + x <- evalSub xe + y <- evalSub ye + realSub sym x y + RealMul xe ye -> do + x <- evalSub xe + y <- evalSub ye + realMul sym x y + RealDiv xe ye -> do + x <- evalSub xe + y <- evalSub ye + realDiv sym x y + RealMod xe ye -> do + x <- evalSub xe + y <- evalSub ye + realMod sym x y + RealLt x_expr y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + realLt sym x y + RealLe x_expr y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + realLe sym x y + RealIsInteger x_expr -> do + x <- evalSub x_expr + isInteger sym x + + ---------------------------------------------------------------------- + -- Float + + -- This is not necessarily considered correct, see crucible#366 + FloatUndef f -> freshConstant sym emptySymbol (iFloatBaseTypeRepr sym f) + + FloatLit f -> iFloatLitSingle sym f + DoubleLit d -> iFloatLitDouble sym d + X86_80Lit ld -> iFloatLitLongDouble sym ld + FloatNaN fi -> iFloatNaN sym fi + FloatPInf fi -> iFloatPInf sym fi + FloatNInf fi -> iFloatNInf sym fi + FloatPZero fi -> iFloatPZero sym fi + FloatNZero fi -> iFloatNZero sym fi + FloatNeg _ (x_expr :: f (FloatType fi)) -> + iFloatNeg @_ @fi sym =<< evalSub x_expr + FloatAbs _ (x_expr :: f (FloatType fi)) -> + iFloatAbs @_ @fi sym =<< evalSub x_expr + FloatSqrt _ rm (x_expr :: f (FloatType fi)) -> + iFloatSqrt @_ @fi sym rm =<< evalSub x_expr + FloatAdd _ rm (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatAdd @_ @fi sym rm x y + FloatSub _ rm (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatSub @_ @fi sym rm x y + FloatMul _ rm (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatMul @_ @fi sym rm x y + FloatDiv _ rm (x_expr :: f (FloatType fi)) y_expr -> do + -- TODO: handle division by zero + x <- evalSub x_expr + y <- evalSub y_expr + iFloatDiv @_ @fi sym rm x y + FloatRem _ (x_expr :: f (FloatType fi)) y_expr -> do + -- TODO: handle division by zero + x <- evalSub x_expr + y <- evalSub y_expr + iFloatRem @_ @fi sym x y + FloatMin _ (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatMin @_ @fi sym x y + FloatMax _ (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatMax @_ @fi sym x y + FloatFMA _ rm (x_expr :: f (FloatType fi)) y_expr z_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + z <- evalSub z_expr + iFloatFMA @_ @fi sym rm x y z + FloatEq (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatEq @_ @fi sym x y + FloatFpEq (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatFpEq @_ @fi sym x y + FloatIte _ c_expr (x_expr :: f (FloatType fi)) y_expr -> do + c <- evalSub c_expr + x <- evalSub x_expr + y <- evalSub y_expr + iFloatIte @_ @fi sym c x y + FloatLt (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatLt @_ @fi sym x y + FloatLe (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatLe @_ @fi sym x y + FloatGt (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatGt @_ @fi sym x y + FloatGe (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatGe @_ @fi sym x y + FloatNe (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatNe @_ @fi sym x y + FloatFpApart (x_expr :: f (FloatType fi)) y_expr -> do + x <- evalSub x_expr + y <- evalSub y_expr + iFloatFpApart @_ @fi sym x y + FloatCast fi rm (x_expr :: f (FloatType fi')) -> + iFloatCast @_ @_ @fi' sym fi rm =<< evalSub x_expr + FloatFromBinary fi x_expr -> iFloatFromBinary sym fi =<< evalSub x_expr + FloatToBinary fi x_expr -> iFloatToBinary sym fi =<< evalSub x_expr + FloatFromBV fi rm x_expr -> iBVToFloat sym fi rm =<< evalSub x_expr + FloatFromSBV fi rm x_expr -> iSBVToFloat sym fi rm =<< evalSub x_expr + FloatFromReal fi rm x_expr -> iRealToFloat sym fi rm =<< evalSub x_expr + FloatToBV w rm (x_expr :: f (FloatType fi)) -> + iFloatToBV @_ @_ @fi sym w rm =<< evalSub x_expr + FloatToSBV w rm (x_expr :: f (FloatType fi)) -> + iFloatToSBV @_ @_ @fi sym w rm =<< evalSub x_expr + FloatToReal (x_expr :: f (FloatType fi)) -> + iFloatToReal @_ @fi sym =<< evalSub x_expr + FloatIsNaN (x_expr :: f (FloatType fi)) -> + iFloatIsNaN @_ @fi sym =<< evalSub x_expr + FloatIsInfinite (x_expr :: f (FloatType fi)) -> + iFloatIsInf @_ @fi sym =<< evalSub x_expr + FloatIsZero (x_expr :: f (FloatType fi)) -> + iFloatIsZero @_ @fi sym =<< evalSub x_expr + FloatIsPositive (x_expr :: f (FloatType fi)) -> + iFloatIsPos @_ @fi sym =<< evalSub x_expr + FloatIsNegative (x_expr :: f (FloatType fi)) -> + iFloatIsNeg @_ @fi sym =<< evalSub x_expr + FloatIsSubnormal (x_expr :: f (FloatType fi)) -> + iFloatIsSubnorm @_ @fi sym =<< evalSub x_expr + FloatIsNormal (x_expr :: f (FloatType fi)) -> + iFloatIsNorm @_ @fi sym =<< evalSub x_expr + + ---------------------------------------------------------------------- + -- Conversions + + NatToInteger x_expr -> do + x <- evalSub x_expr + natToInteger sym x + IntegerToReal x_expr -> do + x <- evalSub x_expr + integerToReal sym x + RealToNat x_expr -> do + x <- evalSub x_expr + realToNat sym x + BvToNat _ xe -> do + bvToNat sym =<< evalSub xe + BvToInteger _ xe -> do + bvToInteger sym =<< evalSub xe + SbvToInteger _ xe -> do + sbvToInteger sym =<< evalSub xe + RealFloor xe -> + realFloor sym =<< evalSub xe + RealCeil xe -> + realCeil sym =<< evalSub xe + RealRound xe -> + realRound sym =<< evalSub xe + IntegerToBV w xe -> do + x <- evalSub xe + integerToBV sym x w + + ---------------------------------------------------------------------- + -- ComplexReal + + Complex r_expr i_expr -> do + r <- evalSub r_expr + i <- evalSub i_expr + mkComplex sym (r :+ i) + RealPart c_expr -> getRealPart sym =<< evalSub c_expr + ImagPart c_expr -> getImagPart sym =<< evalSub c_expr + + -------------------------------------------------------------------- + -- BVs + + -- This is not necessarily considered correct, see crucible#366 + BVUndef w -> + freshConstant sym emptySymbol (BaseBVRepr w) + + BVLit w bv -> bvLit sym w bv + + BVConcat _ _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvConcat sym x y + -- FIXME: there are probably some worthwhile special cases to exploit in "BVSelect" + BVSelect idx n _ xe -> do + x <- evalSub xe + bvSelect sym idx n x + BVTrunc w' _ xe -> do + x <- evalSub xe + bvTrunc sym w' x + BVZext w' _ xe -> do + x <- evalSub xe + bvZext sym w' x + BVSext w' _ xe -> do + x <- evalSub xe + bvSext sym w' x + BVNot _ xe -> + bvNotBits sym =<< evalSub xe + BVAnd _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvAndBits sym x y + BVOr _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvOrBits sym x y + BVXor _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvXorBits sym x y + BVAdd _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvAdd sym x y + BVNeg _ xe -> do + x <- evalSub xe + bvNeg sym x + BVSub _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvSub sym x y + BVMul _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvMul sym x y + BVUdiv _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvUdiv sym x y + BVSdiv _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvSdiv sym x y + BVUrem _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvUrem sym x y + BVSrem _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvSrem sym x y + + BVUlt _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvUlt sym x y + BVSlt _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvSlt sym x y + BoolToBV w xe -> do + x <- evalSub xe + one <- bvLit sym w (BV.one w) + zro <- bvLit sym w (BV.zero w) + bvIte sym x one zro + BVNonzero _ xe -> do + x <- evalSub xe + bvIsNonzero sym x + BVShl _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvShl sym x y + BVLshr _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvLshr sym x y + BVAshr _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvAshr sym x y + BVRol _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvRol sym x y + BVRor _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvRor sym x y + BVCountTrailingZeros _ xe -> do + x <- evalSub xe + bvCountTrailingZeros sym x + BVCountLeadingZeros _ xe -> do + x <- evalSub xe + bvCountLeadingZeros sym x + BVPopcount _ xe -> do + x <- evalSub xe + bvPopcount sym x + BVCarry _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + fst <$> addUnsignedOF sym x y + BVSCarry _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + fst <$> addSignedOF sym x y + BVSBorrow _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + fst <$> subSignedOF sym x y + BVUle _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvUle sym x y + BVSle _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + bvSle sym x y + BVUMin _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + c <- bvUle sym x y + bvIte sym c x y + BVUMax _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + c <- bvUgt sym x y + bvIte sym c x y + BVSMin _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + c <- bvSle sym x y + bvIte sym c x y + BVSMax _ xe ye -> do + x <- evalSub xe + y <- evalSub ye + c <- bvSgt sym x y + bvIte sym c x y + + -------------------------------------------------------------------- + -- Word Maps + + EmptyWordMap w tp -> do + emptyWordMap sym w tp + + InsertWordMap w tp ie ve me -> do + i <- evalSub ie + v <- evalSub ve + m <- evalSub me + insertWordMap sym w tp i v m + + LookupWordMap tp ie me -> do + i <- evalSub ie + m <- evalSub me + x <- lookupWordMap sym (bvWidth i) tp i m + let msg = "WordMap: read an undefined index" ++ + case asBV i of + Nothing -> "" + Just (BV.BV idx) -> " 0x" ++ showHex idx "" + let ex = ReadBeforeWriteSimError msg + readPartExpr bak x ex + + LookupWordMapWithDefault tp ie me de -> do + i <- evalSub ie + m <- evalSub me + d <- evalSub de + x <- lookupWordMap sym (bvWidth i) tp i m + case x of + Unassigned -> return d + PE p v -> do + muxRegForType sym itefns (baseToType tp) p v d + + --------------------------------------------------------------------- + -- Struct + + MkStruct _ exprs -> traverseFC (\x -> RV <$> evalSub x) exprs + + GetStruct st idx _ -> do + struct <- evalSub st + return $ unRV $ struct Ctx.! idx + + SetStruct _ st idx x -> do + struct <- evalSub st + v <- evalSub x + return $ struct & ixF idx .~ RV v + + ---------------------------------------------------------------------- + -- Variant + + InjectVariant ctx idx ve -> do + v <- evalSub ve + return $ injectVariant sym ctx idx v + + ProjectVariant _ctx idx ve -> do + v <- evalSub ve + return $ unVB $ v Ctx.! idx + + ---------------------------------------------------------------------- + -- IdentValueMap + + EmptyStringMap _ -> return Map.empty + + LookupStringMapEntry _ m_expr i_expr -> do + i <- evalSub i_expr + m <- evalSub m_expr + case asString i of + Just (UnicodeLiteral i') -> return $ joinMaybePE (Map.lookup i' m) + Nothing -> addFailedAssertion bak $ + Unsupported callStack "Symbolic string in lookupStringMapEntry" + + InsertStringMapEntry _ m_expr i_expr v_expr -> do + m <- evalSub m_expr + i <- evalSub i_expr + v <- evalSub v_expr + case asString i of + Just (UnicodeLiteral i') -> return $ Map.insert i' v m + Nothing -> addFailedAssertion bak $ + Unsupported callStack "Symbolic string in insertStringMapEntry" + + -------------------------------------------------------------------- + -- Strings + + StringLit x -> stringLit sym x + ShowValue _bt x_expr -> do + x <- evalSub x_expr + stringLit sym (UnicodeLiteral (Text.pack (show (printSymExpr x)))) + ShowFloat _fi x_expr -> do + x <- evalSub x_expr + stringLit sym (UnicodeLiteral (Text.pack (show (printSymExpr x)))) + StringConcat _si x y -> do + x' <- evalSub x + y' <- evalSub y + stringConcat sym x' y' + StringEmpty si -> + stringEmpty sym si + StringLength x -> do + x' <- evalSub x + stringLength sym x' + StringContains x y -> do + x' <- evalSub x + y' <- evalSub y + stringContains sym x' y' + StringIsPrefixOf x y -> do + x' <- evalSub x + y' <- evalSub y + stringIsPrefixOf sym x' y' + StringIsSuffixOf x y -> do + x' <- evalSub x + y' <- evalSub y + stringIsSuffixOf sym x' y' + StringIndexOf x y k -> do + x' <- evalSub x + y' <- evalSub y + k' <- evalSub k + stringIndexOf sym x' y' k' + StringSubstring _si x off len -> do + x' <- evalSub x + off' <- evalSub off + len' <- evalSub len + stringSubstring sym x' off' len' + + --------------------------------------------------------------------- + -- Introspection + + IsConcrete _ v -> do + x <- baseIsConcrete <$> evalSub v + return $! if x then truePred sym else falsePred sym + + --------------------------------------------------------------------- + -- References + + ReferenceEq _ ref1 ref2 -> do + cell1 <- evalSub ref1 + cell2 <- evalSub ref2 + eqReference sym cell1 cell2 diff --git a/src/Lang/Crucible/Simulator/ExecutionTree.hs b/src/Lang/Crucible/Simulator/ExecutionTree.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/ExecutionTree.hs @@ -0,0 +1,1206 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.ExecutionTree +-- Description : Data structure the execution state of the simulator +-- Copyright : (c) Galois, Inc 2014-2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- Execution trees record the state of the simulator as it explores +-- execution paths through a program. This module defines the +-- collection of datatypes that record the state of a running simulator +-- and basic lenses and accessors for these types. See +-- "Lang.Crucible.Simulator.Operations" for the definitions of operations +-- that manipulate these datastructures to drive them through the simulator +-- state machine. +------------------------------------------------------------------------ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fprint-explicit-kinds -Wall #-} +module Lang.Crucible.Simulator.ExecutionTree + ( -- * GlobalPair + GlobalPair(..) + , gpValue + , gpGlobals + + -- * TopFrame + , TopFrame + , crucibleTopFrame + , overrideTopFrame + + -- * CrucibleBranchTarget + , CrucibleBranchTarget(..) + , ppBranchTarget + + -- * AbortedResult + , AbortedResult(..) + , SomeFrame(..) + , filterCrucibleFrames + , arFrames + , ppExceptionContext + + -- * Partial result + , PartialResult(..) + , PartialResultFrame + , partialValue + + -- * Execution states + , ExecResult(..) + , ExecState(..) + , ExecCont + , RunningStateInfo(..) + , ResolvedCall(..) + , resolvedCallHandle + , execResultContext + , execStateContext + , execStateSimState + + -- * Simulator context trees + -- ** Main context data structures + , ValueFromValue(..) + , ValueFromFrame(..) + , PendingPartialMerges(..) + + -- ** Paused Frames + , ResolvedJump(..) + , ControlResumption(..) + , PausedFrame(..) + + -- ** Sibling paths + , VFFOtherPath(..) + , FrameRetType + + -- ** ReturnHandler + , ReturnHandler(..) + + -- * ActiveTree + , ActiveTree(..) + , singletonTree + , activeFrames + , actContext + , actFrame + + -- * Simulator context + -- ** Function bindings + , Override(..) + , FnState(..) + , FunctionBindings(..) + + -- ** Extensions + , ExtensionImpl(..) + , EvalStmtFunc + , emptyExtensionImpl + + -- ** SimContext record + , IsSymInterfaceProof + , SimContext(..) + , Metric(..) + , initSimContext + , withBackend + , ctxSymInterface + , functionBindings + , cruciblePersonality + , profilingMetrics + + -- * SimState + , SimState(..) + , SomeSimState(..) + , initSimState + , stateLocation + + , AbortHandler(..) + , CrucibleState + + -- ** Lenses and accessors + , stateTree + , abortHandler + , stateContext + , stateCrucibleFrame + , stateSymInterface + , stateSolverProof + , stateIntrinsicTypes + , stateOverrideFrame + , stateGlobals + , stateConfiguration + ) where + +import Control.Lens +import Control.Monad.Reader +import Data.Kind +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Parameterized.Ctx +import qualified Data.Parameterized.Context as Ctx +import Data.Text (Text) +import System.Exit (ExitCode) +import System.IO +import qualified Prettyprinter as PP + +import What4.Config (Config) +import What4.Interface (Pred, getConfiguration) +import What4.FunctionName (FunctionName, startFunctionName) +import What4.ProgramLoc (ProgramLoc, plSourceLoc) + +import Lang.Crucible.Backend + ( IsSymInterface, IsSymBackend(..), HasSymInterface(..) + , AbortExecReason, SomeBackend(..), FrameIdentifier, Assumptions + ) +import Lang.Crucible.CFG.Core (BlockID, CFG, CFGPostdom, StmtSeq) +import Lang.Crucible.CFG.Extension (StmtExtension, ExprExtension) +import Lang.Crucible.FunctionHandle (FnHandleMap, HandleAllocator, mkHandle') +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.Evaluation (EvalAppFunc) +import Lang.Crucible.Simulator.GlobalState (SymGlobalState) +import Lang.Crucible.Simulator.Intrinsics (IntrinsicTypes) +import Lang.Crucible.Simulator.RegMap (RegMap, emptyRegMap, RegValue, RegEntry) +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- GlobalPair + +-- | A value of some type 'v' together with a global state. +data GlobalPair sym (v :: Type) = + GlobalPair + { _gpValue :: !v + , _gpGlobals :: !(SymGlobalState sym) + } + +-- | Access the value stored in the global pair. +gpValue :: Lens (GlobalPair sym u) (GlobalPair sym v) u v +gpValue = lens _gpValue (\s v -> s { _gpValue = v }) + +-- | Access the globals stored in the global pair. +gpGlobals :: Simple Lens (GlobalPair sym u) (SymGlobalState sym) +gpGlobals = lens _gpGlobals (\s v -> s { _gpGlobals = v }) + + +------------------------------------------------------------------------ +-- TopFrame + +-- | The currently-executing frame plus the global state associated with it. +type TopFrame sym ext f a = GlobalPair sym (SimFrame sym ext f a) + +-- | Access the Crucible call frame inside a 'TopFrame'. +crucibleTopFrame :: + Lens (TopFrame sym ext (CrucibleLang blocks r) ('Just args)) + (TopFrame sym ext (CrucibleLang blocks r) ('Just args')) + (CallFrame sym ext blocks r args) + (CallFrame sym ext blocks r args') +crucibleTopFrame = gpValue . crucibleSimFrame +{-# INLINE crucibleTopFrame #-} + + +overrideTopFrame :: + Lens (TopFrame sym ext (OverrideLang r) ('Just args)) + (TopFrame sym ext (OverrideLang r') ('Just args')) + (OverrideFrame sym r args) + (OverrideFrame sym r' args') +overrideTopFrame = gpValue . overrideSimFrame +{-# INLINE overrideTopFrame #-} + +------------------------------------------------------------------------ +-- AbortedResult + +-- | An execution path that was prematurely aborted. Note, an abort +-- does not necessarily indicate an error condition. An execution +-- path might abort because it became infeasible (inconsistent path +-- conditions), because the program called an exit primitive, or +-- because of a true error condition (e.g., a failed assertion). +data AbortedResult sym ext where + -- | A single aborted execution with the execution state at time of the abort and the reason. + AbortedExec :: + !AbortExecReason -> + !(GlobalPair sym (SimFrame sym ext l args)) -> + AbortedResult sym ext + + -- | An aborted execution that was ended by a call to 'exit'. + AbortedExit :: + !ExitCode -> + AbortedResult sym ext + + -- | Two separate threads of execution aborted after a symbolic branch, + -- possibly for different reasons. + AbortedBranch :: + !ProgramLoc {- The source location of the branching control flow -} -> + !(Pred sym) {- The symbolic condition -} -> + !(AbortedResult sym ext) {- The abort that occurred along the 'true' branch -} -> + !(AbortedResult sym ext) {- The abort that occurred along the 'false' branch -} -> + AbortedResult sym ext + +------------------------------------------------------------------------ +-- SomeFrame + +-- | This represents an execution frame where its frame type +-- and arguments have been hidden. +data SomeFrame (f :: fk -> argk -> Type) = forall l a . SomeFrame !(f l a) + +-- | Return the program locations of all the Crucible frames. +filterCrucibleFrames :: SomeFrame (SimFrame sym ext) -> Maybe ProgramLoc +filterCrucibleFrames (SomeFrame (MF f)) = Just (frameProgramLoc f) +filterCrucibleFrames _ = Nothing + +-- | Iterate over frames in the result. +arFrames :: Simple Traversal (AbortedResult sym ext) (SomeFrame (SimFrame sym ext)) +arFrames h (AbortedExec e p) = + (\(SomeFrame f') -> AbortedExec e (p & gpValue .~ f')) + <$> h (SomeFrame (p^.gpValue)) +arFrames _ (AbortedExit ec) = pure (AbortedExit ec) +arFrames h (AbortedBranch predicate loc r s) = + AbortedBranch predicate loc <$> arFrames h r + <*> arFrames h s + +-- | Print an exception context +ppExceptionContext :: [SomeFrame (SimFrame sym ext)] -> PP.Doc ann +ppExceptionContext [] = mempty +ppExceptionContext frames = PP.vcat (map pp (init frames)) + where + pp :: SomeFrame (SimFrame sym ext) -> PP.Doc ann + pp (SomeFrame (OF f)) = + PP.pretty "When calling" PP.<+> PP.viaShow (f^.override) + pp (SomeFrame (MF f)) = + PP.pretty "In" PP.<+> PP.viaShow (frameHandle f) PP.<+> + PP.pretty "at" PP.<+> PP.pretty (plSourceLoc (frameProgramLoc f)) + pp (SomeFrame (RF nm _v)) = + PP.pretty "While returning value from" PP.<+> PP.viaShow nm + + +------------------------------------------------------------------------ +-- PartialResult + +-- | A 'PartialResult' represents the result of a computation that +-- might be only partially defined. If the result is a 'TotalResult', +-- the the result is fully defined; however if it is a +-- 'PartialResult', then some of the computation paths that led to +-- this result aborted for some reason, and the resulting value is +-- only defined if the associated condition is true. +data PartialResult sym ext (v :: Type) + + {- | A 'TotalRes' indicates that the the global pair is always defined. -} + = TotalRes !(GlobalPair sym v) + + {- | 'PartialRes' indicates that the global pair may be undefined + under some circumstances. The predicate specifies under what + conditions the 'GlobalPair' is defined. + The 'AbortedResult' describes the circumstances under which + the result would be partial. + -} + | PartialRes !ProgramLoc -- location of symbolic branch point + !(Pred sym) -- if true, global pair is defined + !(GlobalPair sym v) -- the value + !(AbortedResult sym ext) -- failure cases (when pred. is false) + + + +-- | Access the value stored in the partial result. +partialValue :: + Lens (PartialResult sym ext u) + (PartialResult sym ext v) + (GlobalPair sym u) + (GlobalPair sym v) +partialValue f (TotalRes x) = TotalRes <$> f x +partialValue f (PartialRes loc p x r) = (\y -> PartialRes loc p y r) <$> f x +{-# INLINE partialValue #-} + +-- | The result of resolving a function call. +data ResolvedCall p sym ext ret where + -- | A resolved function call to an override. + OverrideCall :: + !(Override p sym ext args ret) -> + !(OverrideFrame sym ret args) -> + ResolvedCall p sym ext ret + + -- | A resolved function call to a Crucible function. + CrucibleCall :: + !(BlockID blocks args) -> + !(CallFrame sym ext blocks ret args) -> + ResolvedCall p sym ext ret + +resolvedCallHandle :: ResolvedCall p sym ext ret -> SomeHandle +resolvedCallHandle (OverrideCall _ frm) = frm ^. overrideHandle +resolvedCallHandle (CrucibleCall _ frm) = frameHandle frm + + +------------------------------------------------------------------------ +-- ExecResult + +-- | Executions that have completed either due to (partial or total) +-- successful completion or by some abort condition. +data ExecResult p sym ext (r :: Type) + = -- | At least one execution path resulted in some return result. + FinishedResult !(SimContext p sym ext) !(PartialResult sym ext r) + -- | All execution paths resulted in an abort condition, and there is + -- no result to return. + | AbortedResult !(SimContext p sym ext) !(AbortedResult sym ext) + -- | An execution stopped somewhere in the middle of a run because + -- a timeout condition occurred. + | TimeoutResult !(ExecState p sym ext r) + + +execResultContext :: ExecResult p sym ext r -> SimContext p sym ext +execResultContext (FinishedResult ctx _) = ctx +execResultContext (AbortedResult ctx _) = ctx +execResultContext (TimeoutResult exst) = execStateContext exst + +execStateContext :: ExecState p sym ext r -> SimContext p sym ext +execStateContext = \case + ResultState res -> execResultContext res + AbortState _ st -> st^.stateContext + UnwindCallState _ _ st -> st^.stateContext + CallState _ _ st -> st^.stateContext + TailCallState _ _ st -> st^.stateContext + ReturnState _ _ _ st -> st^.stateContext + ControlTransferState _ st -> st^.stateContext + RunningState _ st -> st^.stateContext + SymbolicBranchState _ _ _ _ st -> st^.stateContext + OverrideState _ st -> st^.stateContext + BranchMergeState _ st -> st^.stateContext + InitialState stctx _ _ _ _ -> stctx + +execStateSimState :: ExecState p sym ext r + -> Maybe (SomeSimState p sym ext r) +execStateSimState = \case + ResultState _ -> Nothing + AbortState _ st -> Just (SomeSimState st) + UnwindCallState _ _ st -> Just (SomeSimState st) + CallState _ _ st -> Just (SomeSimState st) + TailCallState _ _ st -> Just (SomeSimState st) + ReturnState _ _ _ st -> Just (SomeSimState st) + ControlTransferState _ st -> Just (SomeSimState st) + RunningState _ st -> Just (SomeSimState st) + SymbolicBranchState _ _ _ _ st -> Just (SomeSimState st) + OverrideState _ st -> Just (SomeSimState st) + BranchMergeState _ st -> Just (SomeSimState st) + InitialState _ _ _ _ _ -> Nothing + +----------------------------------------------------------------------- +-- ExecState + +-- | An 'ExecState' represents an intermediate state of executing a +-- Crucible program. The Crucible simulator executes by transitioning +-- between these different states until it results in a 'ResultState', +-- indicating the program has completed. +data ExecState p sym ext (rtp :: Type) + {- | The 'ResultState' is used to indicate that the program has completed. -} + = ResultState + !(ExecResult p sym ext rtp) + + {- | An abort state indicates that the included 'SimState' encountered + an abort event while executing its next step. The state needs to + be unwound to its nearest enclosing branch point and resumed. -} + | forall f a. + AbortState + !AbortExecReason + {- Description of what abort condition occurred -} + !(SimState p sym ext rtp f a) + {- State of the simulator prior to causing the abort condition -} + + {- | An unwind call state occurs when we are about to leave the context of a + function call because of an abort. The included @ValueFromValue@ is the + context of the call site we are about to unwind into, and the @AbortedResult@ + indicates the reason we are aborting. + -} + | forall f a r. + UnwindCallState + !(ValueFromValue p sym ext rtp r) {- Caller's context -} + !(AbortedResult sym ext) {- Abort causing the stack unwind -} + !(SimState p sym ext rtp f a) + + {- | A call state is entered when we are about to make a function call to + the included call frame, which has already resolved the implementation + and arguments to the function. + -} + | forall f a ret. + CallState + !(ReturnHandler ret p sym ext rtp f a) + !(ResolvedCall p sym ext ret) + !(SimState p sym ext rtp f a) + + {- | A tail-call state is entered when we are about to make a function call to + the included call frame, and this is the last action we need to take in the + current caller. Note, we can only enter a tail-call state if there are no + pending merge points in the caller. This means that sometimes calls + that appear to be in tail-call position may nonetheless have to be treated + as ordinary calls. + -} + | forall f a ret. + TailCallState + !(ValueFromValue p sym ext rtp ret) {- Calling context to return to -} + !(ResolvedCall p sym ext ret) {- Function to call -} + !(SimState p sym ext rtp f a) + + {- | A return state is entered after the final return value of a function + is computed, and just before we resolve injecting the return value + back into the caller's context. + -} + | forall f a ret. + ReturnState + !FunctionName {- Name of the function we are returning from -} + !(ValueFromValue p sym ext rtp ret) {- Caller's context -} + !(RegEntry sym ret) {- Return value -} + !(SimState p sym ext rtp f a) + + {- | A running state indicates the included 'SimState' is ready to enter + and execute a Crucible basic block, or to resume a basic block + from a call site. -} + | forall blocks r args. + RunningState + !(RunningStateInfo blocks args) + !(SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)) + + {- | A symbolic branch state indicates that the execution needs to + branch on a non-trivial symbolic condition. The included @Pred@ + is the condition to branch on. The first @PausedFrame@ is + the path that corresponds to the @Pred@ being true, and the second + is the false branch. + -} + | forall f args postdom_args. + SymbolicBranchState + !(Pred sym) {- predicate to branch on -} + !(PausedFrame p sym ext rtp f) {- true path-} + !(PausedFrame p sym ext rtp f) {- false path -} + !(CrucibleBranchTarget f postdom_args) {- merge point -} + !(SimState p sym ext rtp f ('Just args)) + + {- | A control transfer state is entered just prior to invoking a + control resumption. Control resumptions are responsible + for transitioning from the end of one basic block to another, + although there are also some intermediate states related to + resolving switch statements. + -} + | forall f a. + ControlTransferState + !(ControlResumption p sym ext rtp f) + !(SimState p sym ext rtp f ('Just a)) + + {- | An override state indicates the included 'SimState' is prepared to + execute a code override. -} + | forall args ret. + OverrideState + !(Override p sym ext args ret) + {- The override code to execute -} + !(SimState p sym ext rtp (OverrideLang ret) ('Just args)) + {- State of the simulator prior to activating the override -} + + {- | A branch merge state occurs when the included 'SimState' is + in the process of transferring control to the included 'CrucibleBranchTarget'. + We enter a BranchMergeState every time we need to _check_ if there is a + pending branch, even if no branch is pending. During this process, paths may + have to be merged. If several branches must merge at the same control point, + this state may be entered several times in succession before returning + to a 'RunningState'. -} + | forall f args. + BranchMergeState + !(CrucibleBranchTarget f args) + {- Target of the control-flow transfer -} + !(SimState p sym ext rtp f args) + {- State of the simulator before merging pending branches -} + + {- | An initial state indicates the state of a simulator just before execution begins. + It specifies all the initial data necessary to begin simulating. The given + @ExecCont@ will be executed in a fresh @SimState@ representing the default starting + call frame. + -} + | forall ret. rtp ~ RegEntry sym ret => + InitialState + !(SimContext p sym ext) + {- initial 'SimContext' state -} + !(SymGlobalState sym) + {- state of Crucible global variables -} + !(AbortHandler p sym ext (RegEntry sym ret)) + {- initial abort handler -} + !(TypeRepr ret) + {- return type repr -} + !(ExecCont p sym ext (RegEntry sym ret) (OverrideLang ret) ('Just EmptyCtx)) + {- Entry continuation -} + +-- | An action which will construct an 'ExecState' given a current +-- 'SimState'. Such continuations correspond to a single transition +-- of the simulator transition system. +type ExecCont p sym ext r f a = + ReaderT (SimState p sym ext r f a) IO (ExecState p sym ext r) + +-- | Some additional information attached to a @RunningState@ +-- that indicates how we got to this running state. +data RunningStateInfo blocks args + -- | This indicates that we are now in a @RunningState@ because + -- we transferred execution to the start of a basic block. + = RunBlockStart !(BlockID blocks args) + -- | This indicates that we are in a @RunningState@ because we + -- reached the terminal statement of a basic block. + | RunBlockEnd !(Some (BlockID blocks)) + -- | This indicates that we are in a @RunningState@ because we + -- returned from calling the named function. + | RunReturnFrom !FunctionName + -- | This indicates that we are now in a @RunningState@ because + -- we finished branch merging prior to the start of a block. + | RunPostBranchMerge !(BlockID blocks args) + +-- | A 'ResolvedJump' is a block label together with a collection of +-- actual arguments that are expected by that block. These data +-- are sufficient to actually transfer control to the named label. +data ResolvedJump sym blocks + = forall args. + ResolvedJump + !(BlockID blocks args) + !(RegMap sym args) + +-- | When a path of execution is paused by the symbolic simulator +-- (while it first explores other paths), a 'ControlResumption' +-- indicates what actions must later be taken in order to resume +-- execution of that path. +data ControlResumption p sym ext rtp f where + {- | When resuming a paused frame with a @ContinueResumption@, + no special work needs to be done, simply begin executing + statements of the basic block. -} + ContinueResumption :: + !(ResolvedJump sym blocks) -> + ControlResumption p sym ext rtp (CrucibleLang blocks r) + + {- | When resuming with a @CheckMergeResumption@, we must check + for the presence of pending merge points before resuming. -} + CheckMergeResumption :: + !(ResolvedJump sym blocks) -> + ControlResumption p sym ext rtp (CrucibleLang blocks r) + + {- | When resuming a paused frame with a @SwitchResumption@, we must + continue branching to possible alternatives in a variant elimination + statement. In other words, we are still in the process of + transferring control away from the current basic block (which is now + at a final @VariantElim@ terminal statement). -} + SwitchResumption :: + ![(Pred sym, ResolvedJump sym blocks)] {- remaining branches -} -> + ControlResumption p sym ext rtp (CrucibleLang blocks r) + + {- | When resuming a paused frame with an @OverrideResumption@, we + simply return control to the included thunk, which represents + the remaining computation for the override. + -} + OverrideResumption :: + ExecCont p sym ext rtp (OverrideLang r) ('Just args) -> + !(RegMap sym args) -> + ControlResumption p sym ext rtp (OverrideLang r) + +------------------------------------------------------------------------ +-- Paused Frame + +-- | A 'PausedFrame' represents a path of execution that has been postponed +-- while other paths are explored. It consists of a (potentially partial) +-- 'SimFrame' together with some information about how to resume execution +-- of that frame. +data PausedFrame p sym ext rtp f + = forall old_args. + PausedFrame + { pausedFrame :: !(PartialResultFrame sym ext f ('Just old_args)) + , resume :: !(ControlResumption p sym ext rtp f) + , pausedLoc :: !(Maybe ProgramLoc) + } + +-- | This describes the state of the sibling path at a symbolic branch point. +-- A symbolic branch point starts with the sibling in the 'VFFActivePath' +-- state, which indicates that the sibling path still needs to be executed. +-- After the first path to be explored has reached the merge point, the +-- places of the two paths are exchanged, and the completed path is +-- stored in the 'VFFCompletePath' state until the second path also +-- reaches its merge point. The two paths will then be merged, +-- and execution will continue beyond the merge point. +data VFFOtherPath p sym ext ret f args + + {- | This corresponds the a path that still needs to be analyzed. -} + = VFFActivePath + !(PausedFrame p sym ext ret f) + {- Other branch we still need to run -} + + {- | This is a completed execution path. -} + | VFFCompletePath + !(Assumptions sym) + {- Assumptions that we collected while analyzing the branch -} + !(PartialResultFrame sym ext f args) + {- Result of running the other branch -} + + + +{- | This type contains information about the current state of the exploration +of the branching structure of a program. The 'ValueFromFrame' states correspond +to the structure of symbolic branching that occurs within a single function call. + +The type parameters have the following meanings: + + * @p@ is the personality of the simulator (i.e., custom user state). + + * @sym@ is the simulator backend being used. + + * @ext@ specifies what extensions to the Crucible language are enabled + + * @ret@ is the global return type of the entire execution. + + * @f@ is the type of the top frame. +-} + +data ValueFromFrame p sym ext (ret :: Type) (f :: Type) + + {- | We are working on a branch; this could be the first or the second + of both branches (see the 'VFFOtherPath' field). -} + = forall args. + VFFBranch + + !(ValueFromFrame p sym ext ret f) + {- The outer context---what to do once we are done with both branches -} + + !FrameIdentifier + {- This is the frame identifier in the solver before this branch, + so that when we are done we can pop-off the assumptions we accumulated + while processing the branch -} + + !ProgramLoc + {- Program location of the branch point -} + + !(Pred sym) + {- Assertion of currently-active branch -} + + !(VFFOtherPath p sym ext ret f args) + {- Info about the state of the other branch. + If the other branch is "VFFActivePath", then we still + need to process it; if it is "VFFCompletePath", then + it is finished, and so once we are done then we go back to the + outer context. -} + + !(CrucibleBranchTarget f args) + {- Identifies the postdominator where the two branches merge back together -} + + + + {- | We are on a branch where the other branch was aborted before getting + to the merge point. -} + | VFFPartial + + !(ValueFromFrame p sym ext ret f) + {- The other context--what to do once we are done with this branch -} + + !ProgramLoc + {- Program location of the branch point -} + + !(Pred sym) + {- Assertion of currently-active branch -} + + !(AbortedResult sym ext) + {- What happened on the other branch -} + + !PendingPartialMerges + {- should we abort the (outer) sibling branch when it merges with us? -} + + + {- | When we are finished with this branch we should return from the function. -} + | VFFEnd + + !(ValueFromValue p sym ext ret (FrameRetType f)) + + +-- | Data about whether the surrounding context is expecting a merge to +-- occur or not. If the context sill expects a merge, we need to +-- take some actions to indicate that the merge will not occur; +-- otherwise there is no special work to be done. +data PendingPartialMerges = + {- | Don't indicate an abort condition in the context -} + NoNeedToAbort + + {- | Indicate an abort condition in the context when we + get there again. -} + | NeedsToBeAborted + + +{- | This type contains information about the current state of the exploration +of the branching structure of a program. The 'ValueFromValue' states correspond +to stack call frames in a more traditional simulator environment. + +The type parameters have the following meanings: + + * @p@ is the personality of the simulator (i.e., custom user state). + + * @sym@ is the simulator backend being used. + + * @ext@ specifies what extensions to the Crucible language are enabled + + * @ret@ is the global return type of the entire computation + + * @top_return@ is the return type of the top-most call on the stack. +-} +data ValueFromValue p sym ext (ret :: Type) (top_return :: CrucibleType) + + {- | 'VFVCall' denotes a call site in the outer context, and represents + the point to which a function higher on the stack will + eventually return. The three arguments are: + + * The context in which the call happened. + + * The frame of the caller + + * How to modify the current sim frame and resume execution + when we obtain the return value + -} + = forall args caller. + VFVCall + + !(ValueFromFrame p sym ext ret caller) + -- The context in which the call happened. + + !(SimFrame sym ext caller args) + -- The frame of the caller. + + !(ReturnHandler top_return p sym ext ret caller args) + -- How to modify the current sim frame and resume execution + -- when we obtain the return value + + {- | A partial value. + The predicate indicates what needs to hold to avoid the partiality. + The "AbortedResult" describes what could go wrong if the predicate + does not hold. -} + | VFVPartial + !(ValueFromValue p sym ext ret top_return) + !ProgramLoc + !(Pred sym) + !(AbortedResult sym ext) + + {- | The top return value, indicating the program termination point. -} + | (ret ~ RegEntry sym top_return) => VFVEnd + + + +instance PP.Pretty (ValueFromValue p ext sym root rp) where + pretty = ppValueFromValue + +instance PP.Pretty (ValueFromFrame p ext sym ret f) where + pretty = ppValueFromFrame + +instance PP.Pretty (VFFOtherPath ctx sym ext r f a) where + pretty (VFFActivePath _) = PP.pretty "active_path" + pretty (VFFCompletePath _ _) = PP.pretty "complete_path" + +ppValueFromFrame :: ValueFromFrame p sym ext ret f -> PP.Doc ann +ppValueFromFrame vff = + case vff of + VFFBranch ctx _ _ _ other mp -> + PP.vcat + [ PP.pretty "intra_branch" + , PP.indent 2 (PP.pretty other) + , PP.indent 2 (PP.pretty (ppBranchTarget mp)) + , PP.pretty ctx + ] + VFFPartial ctx _ _ _ _ -> + PP.vcat + [ PP.pretty "intra_partial" + , PP.pretty ctx + ] + VFFEnd ctx -> + PP.pretty ctx + +ppValueFromValue :: ValueFromValue p sym ext root tp -> PP.Doc ann +ppValueFromValue vfv = + case vfv of + VFVCall ctx _ _ -> + PP.vcat + [ PP.pretty "call" + , PP.pretty ctx + ] + VFVPartial ctx _ _ _ -> + PP.vcat + [ PP.pretty "inter_partial" + , PP.pretty ctx + ] + VFVEnd -> PP.pretty "root" + + +----------------------------------------------------------------------- +-- parentFrames + +-- | Return parents frames in reverse order. +parentFrames :: ValueFromFrame p sym ext r a -> [SomeFrame (SimFrame sym ext)] +parentFrames c0 = + case c0 of + VFFBranch c _ _ _ _ _ -> parentFrames c + VFFPartial c _ _ _ _ -> parentFrames c + VFFEnd vfv -> vfvParents vfv + +-- | Return parents frames in reverse order. +vfvParents :: ValueFromValue p sym ext r a -> [SomeFrame (SimFrame sym ext)] +vfvParents c0 = + case c0 of + VFVCall c f _ -> SomeFrame f : parentFrames c + VFVPartial c _ _ _ -> vfvParents c + VFVEnd -> [] + +------------------------------------------------------------------------ +-- ReturnHandler + +{- | A 'ReturnHandler' indicates what actions to take to resume +executing in a caller's context once a function call has completed and +the return value is available. + +The type parameters have the following meanings: + + * @ret@ is the type of the return value that is expected. + + * @p@ is the personality of the simulator (i.e., custom user state). + + * @sym@ is the simulator backend being used. + + * @ext@ specifies what extensions to the Crucible language are enabled. + + * @root@ is the global return type of the entire computation. + + * @f@ is the stack type of the caller. + + * @args@ is the type of the local variables in scope prior to the call. +-} +data ReturnHandler (ret :: CrucibleType) p sym ext root f args where + {- | The 'ReturnToOverride' constructor indicates that the calling + context is primitive code written directly in Haskell. + -} + ReturnToOverride :: + (RegEntry sym ret -> SimState p sym ext root (OverrideLang r) ('Just args) -> IO (ExecState p sym ext root)) + {- Remaining override code to run when the return value becomes available -} -> + ReturnHandler ret p sym ext root (OverrideLang r) ('Just args) + + {- | The 'ReturnToCrucible' constructor indicates that the calling context is an + ordinary function call position from within a Crucible basic block. + The included 'StmtSeq' is the remaining statements in the basic block to be + executed following the return. + -} + ReturnToCrucible :: + TypeRepr ret {- Type of the return value -} -> + StmtSeq ext blocks r (ctx ::> ret) {- Remaining statements to execute -} -> + ReturnHandler ret p sym ext root (CrucibleLang blocks r) ('Just ctx) + + {- | The 'TailReturnToCrucible' constructor indicates that the calling context is a + tail call position from the end of a Crucible basic block. Upon receiving + the return value, that value should be immediately returned in the caller's + context as well. + -} + TailReturnToCrucible :: + (ret ~ r) => + ReturnHandler ret p sym ext root (CrucibleLang blocks r) ctx + + +------------------------------------------------------------------------ +-- ActiveTree + +type PartialResultFrame sym ext f args = + PartialResult sym ext (SimFrame sym ext f args) + +{- | An active execution tree contains at least one active execution. + The data structure is organized so that the current execution + can be accessed rapidly. -} +data ActiveTree p sym ext root (f :: Type) args + = ActiveTree + { _actContext :: !(ValueFromFrame p sym ext root f) + , _actResult :: !(PartialResultFrame sym ext f args) + } + +-- | Create a tree with a single top frame. +singletonTree :: + TopFrame sym ext f args -> + ActiveTree p sym ext (RegEntry sym (FrameRetType f)) f args +singletonTree f = ActiveTree { _actContext = VFFEnd VFVEnd + , _actResult = TotalRes f + } + +-- | Access the calling context of the currently-active frame +actContext :: + Lens (ActiveTree p sym ext root f args) + (ActiveTree p sym ext root f args) + (ValueFromFrame p sym ext root f) + (ValueFromFrame p sym ext root f) +actContext = lens _actContext (\s v -> s { _actContext = v }) + +actResult :: + Lens (ActiveTree p sym ext root f args0) + (ActiveTree p sym ext root f args1) + (PartialResult sym ext (SimFrame sym ext f args0)) + (PartialResult sym ext (SimFrame sym ext f args1)) +actResult = lens _actResult setter + where setter s v = ActiveTree { _actContext = _actContext s + , _actResult = v + } +{-# INLINE actResult #-} + +-- | Access the currently-active frame +actFrame :: + Lens (ActiveTree p sym ext root f args) + (ActiveTree p sym ext root f args') + (TopFrame sym ext f args) + (TopFrame sym ext f args') +actFrame = actResult . partialValue +{-# INLINE actFrame #-} + +-- | Return the call stack of all active frames, in +-- reverse activation order (i.e., with callees +-- appearing before callers). +activeFrames :: ActiveTree ctx sym ext root a args -> + [SomeFrame (SimFrame sym ext)] +activeFrames (ActiveTree ctx ar) = + SomeFrame (ar^.partialValue^.gpValue) : parentFrames ctx + + +------------------------------------------------------------------------ +-- SimContext + +-- | A definition of a function's semantics, given as a Haskell action. +data Override p sym ext (args :: Ctx CrucibleType) ret + = Override { overrideName :: FunctionName + , overrideHandler :: forall r. ExecCont p sym ext r (OverrideLang ret) ('Just args) + } + +-- | State used to indicate what to do when function is called. A function +-- may either be defined by writing a Haskell 'Override' or by giving +-- a Crucible control-flow graph representation. +data FnState p sym ext (args :: Ctx CrucibleType) (ret :: CrucibleType) + = UseOverride !(Override p sym ext args ret) + | forall blocks . UseCFG !(CFG ext blocks args ret) !(CFGPostdom blocks) + +-- | A map from function handles to their semantics. +newtype FunctionBindings p sym ext = FnBindings { fnBindings :: FnHandleMap (FnState p sym ext) } + +-- | The type of functions that interpret extension statements. These +-- have access to the main simulator state, and can make fairly arbitrary +-- changes to it. +type EvalStmtFunc p sym ext = + forall rtp blocks r ctx tp'. + StmtExtension ext (RegEntry sym) tp' -> + CrucibleState p sym ext rtp blocks r ctx -> + IO (RegValue sym tp', CrucibleState p sym ext rtp blocks r ctx) + +-- | In order to start executing a simulator, one must provide an implementation +-- of the extension syntax. This includes an evaluator for the added +-- expression forms, and an evaluator for the added statement forms. +data ExtensionImpl p sym ext + = ExtensionImpl + { extensionEval :: + forall bak rtp blocks r ctx. + IsSymBackend sym bak => + bak -> + IntrinsicTypes sym -> + (Int -> String -> IO ()) -> + CrucibleState p sym ext rtp blocks r ctx -> + EvalAppFunc sym (ExprExtension ext) + + , extensionExec :: EvalStmtFunc p sym ext + } + +-- | Trivial implementation for the "empty" extension, which adds no +-- additional syntactic forms. +emptyExtensionImpl :: ExtensionImpl p sym () +emptyExtensionImpl = + ExtensionImpl + { extensionEval = \_sym _iTypes _log _f _state -> \case + , extensionExec = \case + } + +type IsSymInterfaceProof sym a = (IsSymInterface sym => a) -> a + +newtype Metric p sym ext = + Metric { + runMetric :: forall rtp f args. SimState p sym ext rtp f args -> IO Integer + } + +-- | Top-level state record for the simulator. The state contained in this record +-- remains persistent across all symbolic simulator actions. In particular, it +-- is not rolled back when the simulator returns previous program points to +-- explore additional paths, etc. +data SimContext (personality :: Type) (sym :: Type) (ext :: Type) + = SimContext { _ctxBackend :: !(SomeBackend sym) + -- | Class dictionary for @'IsSymInterface' sym@ + , ctxSolverProof :: !(forall a . IsSymInterfaceProof sym a) + , ctxIntrinsicTypes :: !(IntrinsicTypes sym) + -- | Allocator for function handles + , simHandleAllocator :: !(HandleAllocator) + -- | Handle to write messages to. + , printHandle :: !Handle + , extensionImpl :: ExtensionImpl personality sym ext + , _functionBindings :: !(FunctionBindings personality sym ext) + , _cruciblePersonality :: !personality + , _profilingMetrics :: !(Map Text (Metric personality sym ext)) + } + +-- | Create a new 'SimContext' with the given bindings. +initSimContext :: + IsSymBackend sym bak => + bak {- ^ Symbolic backend -} -> + IntrinsicTypes sym {- ^ Implementations of intrinsic types -} -> + HandleAllocator {- ^ Handle allocator for creating new function handles -} -> + Handle {- ^ Handle to write output to -} -> + FunctionBindings personality sym ext {- ^ Initial bindings for function handles -} -> + ExtensionImpl personality sym ext {- ^ Semantics for extension syntax -} -> + personality {- ^ Initial value for custom user state -} -> + SimContext personality sym ext +initSimContext bak muxFns halloc h bindings extImpl personality = + SimContext { _ctxBackend = SomeBackend bak + , ctxSolverProof = \a -> a + , ctxIntrinsicTypes = muxFns + , simHandleAllocator = halloc + , printHandle = h + , extensionImpl = extImpl + , _functionBindings = bindings + , _cruciblePersonality = personality + , _profilingMetrics = Map.empty + } + +withBackend :: + SimContext personality sym ext -> + (forall bak. IsSymBackend sym bak => bak -> a) -> + a +withBackend ctx f = case _ctxBackend ctx of SomeBackend bak -> f bak + +-- | Access the symbolic backend inside a 'SimContext'. +ctxSymInterface :: Getter (SimContext p sym ext) sym +ctxSymInterface = to (\ctx -> + case _ctxBackend ctx of + SomeBackend bak -> backendGetSym bak) + +-- | A map from function handles to their semantics. +functionBindings :: Lens' (SimContext p sym ext) (FunctionBindings p sym ext) +functionBindings = lens _functionBindings (\s v -> s { _functionBindings = v }) + +-- | Access the custom user-state inside the 'SimContext'. +cruciblePersonality :: Lens' (SimContext p sym ext) p +cruciblePersonality = lens _cruciblePersonality (\s v -> s{ _cruciblePersonality = v }) + +profilingMetrics :: Lens' (SimContext p sym ext) (Map Text (Metric p sym ext)) +profilingMetrics = lens _profilingMetrics (\s v -> s { _profilingMetrics = v }) + +------------------------------------------------------------------------ +-- SimState + + +-- | An abort handler indicates to the simulator what actions to take +-- when an abort occurs. Usually, one should simply use the +-- 'defaultAbortHandler' from "Lang.Crucible.Simulator", which +-- unwinds the tree context to the nearest branch point and +-- correctly resumes simulation. However, for some use cases, it +-- may be desirable to take additional or alternate actions on abort +-- events; in which case, the library user may replace the default +-- abort handler with their own. +newtype AbortHandler p sym ext rtp + = AH { runAH :: forall (l :: Type) args. + AbortExecReason -> + ExecCont p sym ext rtp l args + } + +-- | A SimState contains the execution context, an error handler, and +-- the current execution tree. It captures the entire state +-- of the symbolic simulator. +data SimState p sym ext rtp f (args :: Maybe (Ctx.Ctx CrucibleType)) + = SimState { _stateContext :: !(SimContext p sym ext) + , _abortHandler :: !(AbortHandler p sym ext rtp) + , _stateTree :: !(ActiveTree p sym ext rtp f args) + } + +data SomeSimState p sym ext rtp = + forall f args. SomeSimState !(SimState p sym ext rtp f args) + +-- | A simulator state that is currently executing Crucible instructions. +type CrucibleState p sym ext rtp blocks ret args + = SimState p sym ext rtp (CrucibleLang blocks ret) ('Just args) + +-- | Create an initial 'SimState' +initSimState :: + SimContext p sym ext {- ^ initial 'SimContext' state -} -> + SymGlobalState sym {- ^ state of Crucible global variables -} -> + AbortHandler p sym ext (RegEntry sym ret) {- ^ initial abort handler -} -> + TypeRepr ret -> + IO (SimState p sym ext (RegEntry sym ret) (OverrideLang ret) ('Just EmptyCtx)) +initSimState ctx globals ah ret = + do let halloc = simHandleAllocator ctx + h <- mkHandle' halloc startFunctionName Ctx.Empty ret + let startFrame = OverrideFrame { _override = startFunctionName + , _overrideHandle = SomeHandle h + , _overrideRegMap = emptyRegMap + } + let startGP = GlobalPair (OF startFrame) globals + return + SimState + { _stateContext = ctx + , _abortHandler = ah + , _stateTree = singletonTree startGP + } + + +stateLocation :: Getter (SimState p sym ext r f a) (Maybe ProgramLoc) +stateLocation = to f + where + f :: SimState p sym ext r f a -> Maybe ProgramLoc + f st = case st^.stateTree . actFrame . gpValue of + MF cf -> Just $! (frameProgramLoc cf) + OF _ -> Nothing + RF _ _ -> Nothing + + +-- | Access the 'SimContext' inside a 'SimState' +stateContext :: Simple Lens (SimState p sym ext r f a) (SimContext p sym ext) +stateContext = lens _stateContext (\s v -> s { _stateContext = v }) +{-# INLINE stateContext #-} + +-- | Access the current abort handler of a state. +abortHandler :: Simple Lens (SimState p sym ext r f a) (AbortHandler p sym ext r) +abortHandler = lens _abortHandler (\s v -> s { _abortHandler = v }) + +-- | Access the active tree associated with a state. +stateTree :: + Lens (SimState p sym ext rtp f a) + (SimState p sym ext rtp g b) + (ActiveTree p sym ext rtp f a) + (ActiveTree p sym ext rtp g b) +stateTree = lens _stateTree (\s v -> s { _stateTree = v }) +{-# INLINE stateTree #-} + +-- | Access the Crucible call frame inside a 'SimState' +stateCrucibleFrame :: + Lens (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)) + (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a')) + (CallFrame sym ext blocks r a) + (CallFrame sym ext blocks r a') +stateCrucibleFrame = stateTree . actFrame . crucibleTopFrame +{-# INLINE stateCrucibleFrame #-} + +-- | Access the override frame inside a 'SimState' +stateOverrideFrame :: + Lens + (SimState p sym ext q (OverrideLang r) ('Just a)) + (SimState p sym ext q (OverrideLang r) ('Just a')) + (OverrideFrame sym r a) + (OverrideFrame sym r a') +stateOverrideFrame = stateTree . actFrame . gpValue . overrideSimFrame + +-- | Access the globals inside a 'SimState' +stateGlobals :: Simple Lens (SimState p sym ext q f args) (SymGlobalState sym) +stateGlobals = stateTree . actFrame . gpGlobals + +-- | Get the symbolic interface out of a 'SimState' +stateSymInterface :: Getter (SimState p sym ext r f a) sym +stateSymInterface = stateContext . ctxSymInterface + +-- | Get the intrinsic type map out of a 'SimState' +stateIntrinsicTypes :: Getter (SimState p sym ext r f args) (IntrinsicTypes sym) +stateIntrinsicTypes = stateContext . to ctxIntrinsicTypes + +-- | Get the configuration object out of a 'SimState' +stateConfiguration :: Getter (SimState p sym ext r f args) Config +stateConfiguration = to (\s -> stateSolverProof s (getConfiguration (s^.stateSymInterface))) + +-- | Provide the 'IsSymInterface' typeclass dictionary from a 'SimState' +stateSolverProof :: SimState p sym ext r f args -> (forall a . IsSymInterfaceProof sym a) +stateSolverProof s = ctxSolverProof (s^.stateContext) diff --git a/src/Lang/Crucible/Simulator/GlobalState.hs b/src/Lang/Crucible/Simulator/GlobalState.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/GlobalState.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Lang.Crucible.Simulator.GlobalState + ( SymGlobalState + , emptyGlobals + , GlobalEntry(..) + , insertGlobal + , lookupGlobal + , insertRef + , lookupRef + , dropRef + , updateRef + , globalPushBranch + , globalAbortBranch + , globalMuxFn + ) where + +import Control.Applicative ((<|>)) +import Control.Monad.Trans.Class (lift) +import Data.Functor.Identity +import Data.Kind + +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.TraversableF + +import What4.Interface +import What4.Partial +import What4.ProgramLoc + +import Lang.Crucible.CFG.Core +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Backend +import Lang.Crucible.Panic(panic) + +-- | As a map element, type @GlobalEntry sym tp@ models the contents +-- of a 'GlobalVar', which is always defined. +newtype GlobalEntry (sym :: Type) (tp :: CrucibleType) = + GlobalEntry { globalEntryValue :: RegValue sym tp } + +-- | Type @RefCellContents sym tp@ models the contents of a @RefCell@, +-- which holds a partial value. A @RefCell@ not found in the map is +-- considered to represent the 'Unassigned' value. +data RefCellContents (sym :: Type) (tp :: CrucibleType) + = RefCellContents !(Pred sym) !(RegValue sym tp) + +-- | Type @RefCellUpdate sym tp@ models an update to the contents of a +-- @RefCell@. The value @RefCellUpdate Unassigned@ represents the +-- deletion of a @RefCell@. +newtype RefCellUpdate (sym :: Type) (tp :: CrucibleType) = + RefCellUpdate (PartExpr (Pred sym) (RegValue sym tp)) + +------------------------------------------------------------------------ +-- GlobalTable + +data GlobalTable f g = + GlobalTable + { globalVars :: !(MapF.MapF GlobalVar f) + , globalRefs :: !(MapF.MapF RefCell g) + } + +updateGlobalVars :: + (MapF.MapF GlobalVar v -> MapF.MapF GlobalVar v) -> + GlobalTable v r -> GlobalTable v r +updateGlobalVars f (GlobalTable vs rs) = GlobalTable (f vs) rs + +updateGlobalRefs :: + (MapF.MapF RefCell r -> MapF.MapF RefCell r) -> + GlobalTable v r -> GlobalTable v r +updateGlobalRefs f (GlobalTable vs rs) = GlobalTable vs (f rs) + +-- | The empty set of global variable updates. +emptyGlobalTable :: GlobalTable v r +emptyGlobalTable = GlobalTable MapF.empty MapF.empty + +-- | Take the union of two sets of updates, preferring elements from +-- the first set when duplicate keys are encountered. +mergeGlobalTable :: GlobalTable v r -> GlobalTable v r -> GlobalTable v r +mergeGlobalTable (GlobalTable vs1 rs1) (GlobalTable vs2 rs2) = + GlobalTable (MapF.union vs1 vs2) (MapF.union rs1 rs2) + +-- | Maps from global variables and global references to their values. +type GlobalContents sym = GlobalTable (GlobalEntry sym) (RefCellContents sym) + +-- | A collection of updates to the global variables and global +-- references that have happened since a branch push. +type GlobalUpdates sym = GlobalTable (GlobalEntry sym) (RefCellUpdate sym) + +-- | Apply a set of updates to the contents of global memory. +-- @GlobalVar@s cannot be deleted, so we just merge the @GlobalVar@ +-- maps, preferring entries from the first argument. When merging the +-- @RefCell@ maps, a @RefCellUpdate Unassigned@ entry causes the +-- corresponding entry in the old map to be deleted. +applyGlobalUpdates :: forall sym . GlobalUpdates sym -> GlobalContents sym -> GlobalContents sym +applyGlobalUpdates (GlobalTable vs1 rs1) (GlobalTable vs2 rs2) = + GlobalTable (MapF.union vs1 vs2) (runIdentity (MapF.mergeWithKeyM both left Identity rs1 rs2)) + where + upd :: forall tp. RefCellUpdate sym tp -> Maybe (RefCellContents sym tp) + upd (RefCellUpdate Unassigned) = Nothing + upd (RefCellUpdate (PE p e)) = Just (RefCellContents p e) + + both :: forall tp. RefCell tp -> RefCellUpdate sym tp -> RefCellContents sym tp -> Identity (Maybe (RefCellContents sym tp)) + both _ u _ = Identity (upd u) + + left :: MapF.MapF RefCell (RefCellUpdate sym) -> Identity (MapF.MapF RefCell (RefCellContents sym)) + left m = Identity (MapF.mapMaybe upd m) + +------------------------------------------------------------------------ +-- GlobalFrames + +-- | The state of global memory as a stack of changes separated by +-- branch pushes. The second parameter of 'BranchFrame' caches +-- the combined view of memory as of the previous branch push. +data GlobalFrames (sym :: Type) = + InitialFrame !(GlobalContents sym) + | BranchFrame !(GlobalUpdates sym) (GlobalContents sym) !(GlobalFrames sym) + +-- | The depth of this value represents the number of symbolic +-- branches currently pending. We use this primarily as a sanity check +-- to help find bugs where we fail to match up calls to +-- 'globalPushBranch' with 'globalAbortBranch'/'globalMuxFn'. +globalPendingBranches :: GlobalFrames sym -> Int +globalPendingBranches (InitialFrame _) = 0 +globalPendingBranches (BranchFrame _ _ gf) = 1 + globalPendingBranches gf + +-- | The empty set of global variable bindings. +emptyGlobalFrames :: GlobalFrames sym +emptyGlobalFrames = InitialFrame emptyGlobalTable + +------------------------------------------------------------------------ +-- GlobalTable + +-- | A map from global variables to their value. +data SymGlobalState (sym :: Type) = + GlobalState + { globalFrames :: !(GlobalFrames sym) + -- ^ The stack of updates to global memory, separated by branch + -- pushes. This field only contains values with ordinary crucible + -- types (i.e. not intrinsic), which do not have mux operations + -- that require branch push notifications. + , globalIntrinsics :: !(GlobalContents sym) + -- ^ The set of updates since initialization to vars and refs that + -- have intrinsic or "any" types, which must be notified of + -- branch pushes. + } + +-- | The empty set of global variable bindings. +emptyGlobals :: SymGlobalState sym +emptyGlobals = GlobalState emptyGlobalFrames emptyGlobalTable + +-- | Test whether this type could be an intrinsic type, which must be +-- notified of branch pushes and aborts. +needsNotification :: TypeRepr tp -> Bool +needsNotification tr = + case tr of + IntrinsicRepr{} -> True + AnyRepr -> True + _ -> False + +-- | Lookup a global variable in the state. +lookupGlobal :: GlobalVar tp -> SymGlobalState sym -> Maybe (RegValue sym tp) +lookupGlobal g gst + | needsNotification (globalType g) = + globalEntryValue <$> MapF.lookup g (globalVars (globalIntrinsics gst)) + | otherwise = + globalEntryValue <$> go (globalFrames gst) + where + -- We never have to search more than one level deep, because the + -- 'BranchFrame' constructor caches the combined contents of the + -- rest of the 'GlobalFrames'. + go (InitialFrame c) = MapF.lookup g (globalVars c) + go (BranchFrame u c _) = MapF.lookup g (globalVars u) <|> MapF.lookup g (globalVars c) + +-- | Set the value of a global in the state, or create a new global variable. +insertGlobal :: + GlobalVar tp -> + RegValue sym tp -> + SymGlobalState sym -> + SymGlobalState sym +insertGlobal g v gst + | needsNotification (globalType g) = + gst{ globalIntrinsics = updateGlobalVars (MapF.insert g x) (globalIntrinsics gst) } + | otherwise = + gst{ globalFrames = upd (globalFrames gst) } + where + x = GlobalEntry v + upd (InitialFrame c) = InitialFrame (updateGlobalVars (MapF.insert g x) c) + upd (BranchFrame u c gf) = BranchFrame (updateGlobalVars (MapF.insert g x) u) c gf + -- NOTE: While global variables can be updated within branches, it + -- should probably be forbidden to create a new global variable in + -- a branch. However, we don't check for this currently. (An error + -- will happen later when merging the branches if the set of + -- global variables does not match.) + +-- | Look up the value of a reference cell in the state. +lookupRef :: RefCell tp -> SymGlobalState sym -> PartExpr (Pred sym) (RegValue sym tp) +lookupRef r gst + | needsNotification (refType r) = post $ MapF.lookup r (globalRefs (globalIntrinsics gst)) + | otherwise = go (globalFrames gst) + where + -- We never have to search more than one level deep, because the + -- 'BranchFrame' constructor caches the combined contents of the + -- rest of the 'GlobalFrames'. + post = maybe Unassigned (\(RefCellContents p e) -> PE p e) + go (InitialFrame c) = post $ MapF.lookup r (globalRefs c) + go (BranchFrame u c _) = + case MapF.lookup r (globalRefs u) of + Just (RefCellUpdate pe) -> pe + Nothing -> post $ MapF.lookup r (globalRefs c) + +-- | Set the value of a reference cell in the state. +insertRef :: + IsExprBuilder sym => + sym -> + RefCell tp -> + RegValue sym tp -> + SymGlobalState sym -> + SymGlobalState sym +insertRef sym r v = updateRef r (PE (truePred sym) v) + +-- | Write a partial value to a reference cell in the state. +updateRef :: + -- IsExprBuilder sym => + RefCell tp -> + PartExpr (Pred sym) (RegValue sym tp) -> + SymGlobalState sym -> + SymGlobalState sym +updateRef r pe gst + | needsNotification (refType r) = + gst{ globalIntrinsics = updateGlobalRefs ins (globalIntrinsics gst) } + | otherwise = + gst{ globalFrames = upd (globalFrames gst) } + where + ins = + case pe of + Unassigned -> MapF.delete r + PE p e -> MapF.insert r (RefCellContents p e) + upd (InitialFrame c) = InitialFrame (updateGlobalRefs ins c) + upd (BranchFrame u c gf) = + BranchFrame (updateGlobalRefs (MapF.insert r (RefCellUpdate pe)) u) c gf + +-- | Reset a reference cell to the uninitialized state. @'dropRef' r@ is +-- equivalent to @'updateRef' r 'Unassigned'@. +dropRef :: RefCell tp -> SymGlobalState sym -> SymGlobalState sym +dropRef r = updateRef r Unassigned + +-- | Mark a branch point in the global state. Later calls to +-- 'globalMuxFn' will assume that the input states are identical up +-- until the most recent branch point. +globalPushBranch :: + forall sym . + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + SymGlobalState sym -> + IO (SymGlobalState sym) +globalPushBranch sym iTypes (GlobalState gf (GlobalTable vs rs)) = + do -- Notify intrinsic-typed vars and refs of the branch push. + vs' <- MapF.traverseWithKey + (\v (GlobalEntry e) -> + GlobalEntry <$> pushBranchForType sym iTypes (globalType v) e) + vs + rs' <- MapF.traverseWithKey + (\r (RefCellContents p e) -> + RefCellContents p <$> pushBranchForType sym iTypes (refType r) e) + rs + --loc <- getCurrentProgramLoc sym + --putStrLn $ unwords ["PUSH BRANCH:", show d, show $ plSourceLoc loc] + let gf' = BranchFrame emptyGlobalTable cache gf + return (GlobalState gf' (GlobalTable vs' rs')) + where + cache = + case gf of + InitialFrame c -> c + BranchFrame u c _ -> applyGlobalUpdates u c + +-- | Merge a set of updates into the outermost frame of a stack of global frames. +abortBranchFrame :: GlobalUpdates sym -> GlobalFrames sym -> GlobalFrames sym +abortBranchFrame u (InitialFrame c) = InitialFrame (applyGlobalUpdates u c) +abortBranchFrame u (BranchFrame u' c gf) = BranchFrame (mergeGlobalTable u u') c gf + +-- | Remove the most recent branch point marker, and thus cancel the +-- effect of the most recent 'globalPushBranch'. +globalAbortBranch :: + forall sym . + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + SymGlobalState sym -> + IO (SymGlobalState sym) + +globalAbortBranch sym iTypes (GlobalState (BranchFrame u _ gf) (GlobalTable vs rs)) = + do -- Notify intrinsic-typed vars and refs of the branch abort. + vs' <- MapF.traverseWithKey + (\v (GlobalEntry e) -> + GlobalEntry <$> abortBranchForType sym iTypes (globalType v) e) + vs + rs' <- MapF.traverseWithKey + (\r (RefCellContents p e) -> + RefCellContents p <$> abortBranchForType sym iTypes (refType r) e) + rs + --loc <- getCurrentProgramLoc sym + --putStrLn $ unwords ["ABORT BRANCH:", show (d-1), show $ plSourceLoc loc] + let gf' = abortBranchFrame u gf + return (GlobalState gf' (GlobalTable vs' rs')) + +globalAbortBranch sym _ (GlobalState (InitialFrame _) _) = + do loc <- getCurrentProgramLoc sym + panic "GlobalState.globalAbortBranch" + [ "Attempting to commit global changes at branch depth 0" + , "*** Location: " ++ show (plSourceLoc loc) + ] + +muxPartialRegForType :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + TypeRepr tp -> + MuxFn (Pred sym) (PartExpr (Pred sym) (RegValue sym tp)) +muxPartialRegForType sym iteFns tp = + mergePartial sym (\c u v -> lift $ muxRegForType sym iteFns tp c u v) + +-- | A symbolic mux function for @GlobalContents@. +muxGlobalContents :: + forall sym . + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + MuxFn (Pred sym) (GlobalContents sym) +muxGlobalContents sym iteFns c (GlobalTable vs1 rs1) (GlobalTable vs2 rs2) = + do vs' <- MapF.mergeWithKeyM muxEntry checkNullMap checkNullMap vs1 vs2 + rs' <- MapF.mergeWithKeyM muxRef refLeft refRight rs1 rs2 + return (GlobalTable vs' rs') + where + muxEntry :: GlobalVar tp + -> GlobalEntry sym tp + -> GlobalEntry sym tp + -> IO (Maybe (GlobalEntry sym tp)) + muxEntry g (GlobalEntry u) (GlobalEntry v) = + Just . GlobalEntry <$> muxRegForType sym iteFns (globalType g) c u v + + muxRef :: RefCell tp + -> RefCellContents sym tp + -> RefCellContents sym tp + -> IO (Maybe (RefCellContents sym tp)) + muxRef r (RefCellContents pu u) (RefCellContents pv v) = + do uv <- muxRegForType sym iteFns (refType r) c u v + p <- itePred sym c pu pv + return . Just $ RefCellContents p uv + + -- Make a partial value undefined unless the given predicate holds. + restrictRefCellContents :: Pred sym -> RefCellContents sym tp -> IO (RefCellContents sym tp) + restrictRefCellContents p1 (RefCellContents p2 x) = + do p' <- andPred sym p1 p2 + return (RefCellContents p' x) + + refLeft :: MapF.MapF RefCell (RefCellContents sym) -> IO (MapF.MapF RefCell (RefCellContents sym)) + refLeft m = traverseF (restrictRefCellContents c) m + + refRight :: MapF.MapF RefCell (RefCellContents sym) -> IO (MapF.MapF RefCell (RefCellContents sym)) + refRight m = + do cnot <- notPred sym c + traverseF (restrictRefCellContents cnot) m + + -- Sets of global variables are required to be the same in both branches. + checkNullMap :: MapF.MapF GlobalVar (GlobalEntry sym) + -> IO (MapF.MapF GlobalVar (GlobalEntry sym)) + checkNullMap m + | MapF.null m = return m + | otherwise = + panic "GlobalState.globalMuxFn" + [ "Different global variables in each branch." ] + +data EitherOrBoth f g (tp :: k) = + JustLeft (f tp) | Both (f tp) (g tp) | JustRight (g tp) + +-- | A symbolic mux function for @GlobalUpdates@. For cases where a +-- pre-existing value is updated only on one side, we require a +-- @GlobalContents@ to look up the previous value to use in place of +-- the missing update. +muxGlobalUpdates :: + forall sym . + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + GlobalContents sym -> + MuxFn (Pred sym) (GlobalUpdates sym) +muxGlobalUpdates sym iteFns (GlobalTable vs0 rs0) c (GlobalTable vs1 rs1) (GlobalTable vs2 rs2) = + do -- Zip together the two maps of globals. + vs3 <- MapF.mergeWithKeyM + (\_ x y -> return (Just (Both x y))) + (traverseF (return . JustLeft)) + (traverseF (return . JustRight)) + vs1 vs2 + vs' <- MapF.mergeWithKeyM + (\k x0 e -> + Just <$> + case e of + JustLeft x1 -> muxEntry k x1 x0 -- use old value x0 for right side + JustRight x2 -> muxEntry k x0 x2 -- use old value x0 for left side + Both x1 x2 -> muxEntry k x1 x2) + (\_ -> return MapF.empty) -- old values updated on neither side are excluded from merged updates + (MapF.traverseWithKey $ \k e -> + case e of + JustLeft _ -> panicNull -- panic if there is no old value + JustRight _ -> panicNull -- panic if there is no old value + Both x1 x2 -> muxEntry k x1 x2) + vs0 + vs3 + + -- Zip together the two maps of references. + rs3 <- MapF.mergeWithKeyM + (\_ x y -> return (Just (Both x y))) + (traverseF (return . JustLeft)) + (traverseF (return . JustRight)) + rs1 rs2 + rs' <- MapF.mergeWithKeyM + (\k (RefCellContents p e) eb -> + let x0 = RefCellUpdate (PE p e) in + Just <$> + case eb of + JustLeft x1 -> muxRef k x1 x0 -- use old value x0 for right side + JustRight x2 -> muxRef k x0 x2 -- use old value x0 for left side + Both x1 x2 -> muxRef k x1 x2) + (\_ -> return MapF.empty) -- old values updated on neither side are excluded from merged updates + (MapF.traverseWithKey $ \k e -> + case e of + JustLeft x1 -> muxRef k x1 undef -- x1 was newly-created on left side, undefined on right + JustRight x2 -> muxRef k undef x2 -- x2 was newly-created on right side, undefined on left + Both x1 x2 -> muxRef k x1 x2) + rs0 + rs3 + return (GlobalTable vs' rs') + where + undef :: forall tp. RefCellUpdate sym tp + undef = RefCellUpdate Unassigned + + muxEntry :: GlobalVar tp + -> GlobalEntry sym tp + -> GlobalEntry sym tp + -> IO (GlobalEntry sym tp) + muxEntry g (GlobalEntry u) (GlobalEntry v) = + GlobalEntry <$> muxRegForType sym iteFns (globalType g) c u v + + muxRef :: RefCell tp + -> RefCellUpdate sym tp + -> RefCellUpdate sym tp + -> IO (RefCellUpdate sym tp) + muxRef r (RefCellUpdate pe1) (RefCellUpdate pe2) = + RefCellUpdate <$> muxPartialRegForType sym iteFns (refType r) c pe1 pe2 + + panicNull = + panic "GlobalState.globalMuxFn" + [ "Different global variables in each branch." ] + +-- | Compute a symbolic if-then-else on two global states. The +-- function assumes that the two states were identical up until the +-- most recent branch point marked by 'globalPushBranch'. This most +-- recent branch point marker is also popped from the stack. +globalMuxFn :: + forall sym . + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + MuxFn (Pred sym) (SymGlobalState sym) + +globalMuxFn sym iteFns cond + (GlobalState (BranchFrame u1 cache1 gf1) s1) + (GlobalState (BranchFrame u2 _cache2 gf2) s2) + | globalPendingBranches gf1 == globalPendingBranches gf2 = + -- We assume gf1 is in fact equal to gf2, which should be the case + -- if we've followed the appropriate branching discipline. + do u3 <- muxGlobalUpdates sym iteFns cache1 cond u1 u2 + s3 <- muxGlobalContents sym iteFns cond s1 s2 + --let gf' = updateFrame (mergeGlobalUpdates x') gf1 + let gf3 = + case gf1 of + InitialFrame c' -> InitialFrame (applyGlobalUpdates u3 c') + BranchFrame u' c' gf' -> BranchFrame (mergeGlobalTable u3 u') c' gf' + return (GlobalState gf3 s3) + +globalMuxFn sym _ _ (GlobalState gf1 _) (GlobalState gf2 _) = + do loc <- getCurrentProgramLoc sym + panic "GlobalState.globalMuxFn" + [ "Attempting to merge global states of incorrect branch depths:" + , " *** Depth 1: " ++ show (globalPendingBranches gf1) + , " *** Depth 2: " ++ show (globalPendingBranches gf2) + , " *** Location: " ++ show (plSourceLoc loc) + ] diff --git a/src/Lang/Crucible/Simulator/Intrinsics.hs b/src/Lang/Crucible/Simulator/Intrinsics.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/Intrinsics.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.Intrinsics +-- Description : Basic definitions for defining intrinsic types +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- 'Intrinsic' types can be used to extend the basic set of types available +-- to the Crucible simulator. A new intrinsic type is defined by +-- implementing an `IntrinsicClass` instance, which binds a type-level name +-- to a particular impelementation. To use an intrinsic type, one must +-- register the associated `IntrinsicMuxFn` value with the simulator +-- prior to starting it. This is done by building an `IntrinsicMuxFns` +-- map to be passed to the `initSimContext` function. +----------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Lang.Crucible.Simulator.Intrinsics + ( -- * Intrinsic types + IntrinsicClass(..) + , GetIntrinsic + , IntrinsicMuxFn(..) + , IntrinsicTypes + , emptyIntrinsicTypes + , typeError + ) where + +import Data.Kind +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.SymbolRepr +import qualified GHC.TypeLits (Symbol) +import qualified GHC.TypeLits as TL +import GHC.Stack + +import What4.Interface +import Lang.Crucible.Panic +import Lang.Crucible.Types + +-- | Type family for intrinsic type representations. Intrinsic types +-- are identified by a type-level `Symbol`, and this typeclass allows +-- backends to define implementations for these types. +-- +-- An instance of this class defines both an instance for the +-- `Intrinsic` type family (which defines the runtime representation +-- for this intrinsic type) and also the `muxIntrinsic` method +-- (which defines how to merge to intrinsic values when the simulator +-- reaches a merge point). +-- +-- Note: Instances of this will typically end up as orphan instances. +-- This warning is normally quite important, as orphan instances allow +-- one to define multiple instances for a particular class. However, in +-- this case, 'IntrinsicClass' contains a type family, and GHC will globally +-- check consistency of all type family instances. Consequently, there +-- can be at most one implementation of 'IntrinsicClass' in a program. +class IntrinsicClass (sym :: Type) (nm :: GHC.TypeLits.Symbol) where + -- | The 'Intrinsic' type family defines, for a given backend and symbol name, + -- the runtime implementation of that Crucible intrinsic type. + type Intrinsic (sym :: Type) (nm :: GHC.TypeLits.Symbol) (ctx :: Ctx CrucibleType) :: Type + + -- | The push branch function is called when an intrinsic value is + -- passed through a symbolic branch. This allows it to do any + -- necessary bookkeeping to prepare for an upcoming merge. + -- A push branch should eventually be followed by a matching + -- abort or mux call. + pushBranchIntrinsic + :: sym + -> IntrinsicTypes sym + -> SymbolRepr nm + -> CtxRepr ctx + -> Intrinsic sym nm ctx + -> IO (Intrinsic sym nm ctx) + pushBranchIntrinsic _ _ _ _ = return + + -- | The abort branch function is called when an intrinsic value + -- reaches a merge point, but the sibling branch has aborted. + abortBranchIntrinsic + :: sym + -> IntrinsicTypes sym + -> SymbolRepr nm + -> CtxRepr ctx + -> Intrinsic sym nm ctx + -> IO (Intrinsic sym nm ctx) + abortBranchIntrinsic _ _ _ _ = return + + -- | The `muxIntrinsic` method defines the if-then-else operation that is used + -- when paths are merged in the simulator and intrinsic types need to be used. + muxIntrinsic :: sym + -> IntrinsicTypes sym + -> SymbolRepr nm + -> CtxRepr ctx + -> Pred sym + -> Intrinsic sym nm ctx + -> Intrinsic sym nm ctx + -> IO (Intrinsic sym nm ctx) + +-- | Sometimes it is convenient to provide a 'CrucibleType' as the type +-- argument to 'Intrinsic', rather than the symbol and context. If you +-- accidentally supply a non-'IntrinsicType' type, this family will be stuck. +type family GetIntrinsic sym ity where + GetIntrinsic sym (IntrinsicType nm ctx) = Intrinsic sym nm ctx + GetIntrinsic sym x = TL.TypeError + ( ('TL.Text "Type mismatch:") + 'TL.:$$: ('TL.Text " Expected ‘IntrinsicType a b’") + 'TL.:$$: ('TL.Text " Actual " 'TL.:<>: 'TL.ShowType x) + 'TL.:$$: ('TL.Text "In type family application ‘GetIntrinsic (" 'TL.:<>: 'TL.ShowType sym 'TL.:<>: 'TL.Text ") (" 'TL.:<>: 'TL.ShowType x 'TL.:<>: 'TL.Text ")’") + ) + +-- | The `IntrinsicMuxFn` datatype allows an `IntrinsicClass` instance +-- to be packaged up into a value. This allows us to get access to 'IntrinsicClass' +-- instance methods (the `muxIntrinsic` method in particular) at runtime even +-- for symbol names that are not known statically. +-- +-- By packaging up a type class instance (rather than just providing some method with the +-- same signature as `muxIntrinsic`) we get the compiler to ensure that a single +-- distinguished implementation is always used for each backend/symbol name combination. +-- This prevents any possible confusion between different parts of the system. +data IntrinsicMuxFn (sym :: Type) (nm :: Symbol) where + IntrinsicMuxFn :: IntrinsicClass sym nm => IntrinsicMuxFn sym nm + + +-- | `IntrinsicTypes` is a map from symbol name representatives to `IntrinsicMuxFn` +-- values. Such a map is useful for providing access to intrinsic type implementations +-- that are not known statically at compile time. +type IntrinsicTypes sym = MapF.MapF SymbolRepr (IntrinsicMuxFn sym) + +-- | An empty collection of intrinsic types, for cases where no additional types are required +emptyIntrinsicTypes :: IntrinsicTypes sym +emptyIntrinsicTypes = MapF.empty + +-- | Utility function for reporting errors when improper Crucible type arguments +-- are applied to an intrinsic type symbol. +typeError :: HasCallStack => SymbolRepr nm -> CtxRepr ctx -> b +typeError nm ctx = + panic "Crucible type error" + [ "Named type constructor '" ++ show nm ++ "' applied to incorrect arguments:" + , show ctx + ] diff --git a/src/Lang/Crucible/Simulator/Operations.hs b/src/Lang/Crucible/Simulator/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/Operations.hs @@ -0,0 +1,1139 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.Operations +-- Description : Basic operations on execution trees +-- Copyright : (c) Galois, Inc 2014-2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- Operations corresponding to basic control-flow events on +-- simulator execution trees. +------------------------------------------------------------------------ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fprint-explicit-kinds -Wall #-} +module Lang.Crucible.Simulator.Operations + ( -- * Control-flow operations + continue + , jumpToBlock + , conditionalBranch + , variantCases + , returnValue + , callFunction + , tailCallFunction + , runOverride + , runAbortHandler + , runErrorHandler + , runGenericErrorHandler + , performIntraFrameMerge + , performIntraFrameSplit + , performFunctionCall + , performTailCall + , performReturn + , performControlTransfer + , resumeFrame + , resumeValueFromValueAbort + , overrideSymbolicBranch + + -- * Resolving calls + , ResolvedCall(..) + , UnresolvableFunction(..) + , resolveCall + , resolvedCallName + + -- * Abort handlers + , abortExecAndLog + , abortExec + , defaultAbortHandler + + -- * Call tree manipulations + , pushCallFrame + , replaceTailFrame + , isSingleCont + , unwindContext + , extractCurrentPath + , asContFrame + , forgetPostdomFrame + ) where + +import Prelude hiding (pred) + +import qualified Control.Exception as Ex +import Control.Lens +import Control.Monad (when, void) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT(..), withReaderT) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some +import qualified Data.Vector as V +import Data.Type.Equality hiding (sym) +import System.IO +import qualified Prettyprinter as PP + +import What4.Config +import What4.Interface +import What4.FunctionName +import What4.ProgramLoc + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Extension +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic(panic) +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError + +--------------------------------------------------------------------- +-- Intermediate state branching/merging + +-- | Merge two globals together. +mergeGlobalPair :: + MuxFn p v -> + MuxFn p (SymGlobalState sym) -> + MuxFn p (GlobalPair sym v) +mergeGlobalPair merge_fn global_fn c x y = + GlobalPair <$> merge_fn c (x^.gpValue) (y^.gpValue) + <*> global_fn c (x^.gpGlobals) (y^.gpGlobals) + +mergeAbortedResult :: + ProgramLoc {- ^ Program location of control-flow branching -} -> + Pred sym {- ^ Branch predicate -} -> + AbortedResult sym ext -> + AbortedResult sym ext -> + AbortedResult sym ext +mergeAbortedResult _ _ (AbortedExit ec) _ = AbortedExit ec +mergeAbortedResult _ _ _ (AbortedExit ec) = AbortedExit ec +mergeAbortedResult loc pred q r = AbortedBranch loc pred q r + +mergePartialAndAbortedResult :: + IsExprBuilder sym => + sym -> + ProgramLoc {- ^ Program location of control-flow branching -} -> + Pred sym {- ^ This needs to hold to avoid the aborted result -} -> + PartialResult sym ext v -> + AbortedResult sym ext -> + IO (PartialResult sym ext v) +mergePartialAndAbortedResult sym loc pred ar r = do + case ar of + TotalRes gp -> return $! PartialRes loc pred gp r + PartialRes loc' d gp q -> + do e <- andPred sym pred d + return $! PartialRes loc' e gp (mergeAbortedResult loc pred q r) + + +mergeCrucibleFrame :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + CrucibleBranchTarget f args {- ^ Target of branch -} -> + MuxFn (Pred sym) (SimFrame sym ext f args) +mergeCrucibleFrame sym muxFns tgt p x0 y0 = + case tgt of + BlockTarget _b_id -> do + let x = fromCallFrame x0 + let y = fromCallFrame y0 + z <- mergeRegs sym muxFns p (x^.frameRegs) (y^.frameRegs) + pure $! MF (x & frameRegs .~ z) + ReturnTarget -> do + let x = fromReturnFrame x0 + let y = fromReturnFrame y0 + RF (x0^.frameFunctionName) <$> muxRegEntry sym muxFns p x y + + +mergePartialResult :: + IsSymInterface sym => + SimState p sym ext root f args -> + CrucibleBranchTarget f args -> + MuxFn (Pred sym) (PartialResultFrame sym ext f args) +mergePartialResult s tgt pred x y = + let sym = s^.stateSymInterface + iteFns = s^.stateIntrinsicTypes + merge_val = mergeCrucibleFrame sym iteFns tgt + merge_fn = mergeGlobalPair merge_val (globalMuxFn sym iteFns) + in + case x of + TotalRes cx -> + case y of + TotalRes cy -> + TotalRes <$> merge_fn pred cx cy + + PartialRes loc py cy fy -> + PartialRes loc <$> orPred sym pred py + <*> merge_fn pred cx cy + <*> pure fy + + PartialRes loc px cx fx -> + case y of + TotalRes cy -> + do pc <- notPred sym pred + PartialRes loc <$> orPred sym pc px + <*> merge_fn pred cx cy + <*> pure fx + + PartialRes loc' py cy fy -> + PartialRes loc' <$> itePred sym pred px py + <*> merge_fn pred cx cy + <*> pure (AbortedBranch loc' pred fx fy) + +forgetPostdomFrame :: + PausedFrame p sym ext rtp g -> + PausedFrame p sym ext rtp g +forgetPostdomFrame (PausedFrame frm cont loc) = PausedFrame frm (f cont) loc + where + f (CheckMergeResumption jmp) = ContinueResumption jmp + f x = x + + +pushPausedFrame :: + IsSymInterface sym => + PausedFrame p sym ext rtp g -> + ReaderT (SimState p sym ext rtp f ma) IO (PausedFrame p sym ext rtp g) +pushPausedFrame (PausedFrame frm res loc) = + do sym <- view stateSymInterface + iTypes <- view stateIntrinsicTypes + frm' <- lift (frm & traverseOf (partialValue.gpGlobals) (globalPushBranch sym iTypes)) + res' <- lift (pushControlResumption sym iTypes res) + return (PausedFrame frm' res' loc) + +pushControlResumption :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + ControlResumption p sym ext rtp g -> + IO (ControlResumption p sym ext rtp g) +pushControlResumption sym iTypes res = + case res of + ContinueResumption jmp -> + ContinueResumption <$> pushResolvedJump sym iTypes jmp + CheckMergeResumption jmp -> + CheckMergeResumption <$> pushResolvedJump sym iTypes jmp + SwitchResumption ps -> + SwitchResumption <$> (traverse._2) (pushResolvedJump sym iTypes) ps + OverrideResumption k args -> + OverrideResumption k <$> pushBranchRegs sym iTypes args + +pushResolvedJump :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + ResolvedJump sym branches -> + IO (ResolvedJump sym branches) +pushResolvedJump sym iTypes (ResolvedJump block_id args) = + ResolvedJump block_id <$> pushBranchRegs sym iTypes args + + +abortCrucibleFrame :: + IsSymInterface sym => + sym -> + IntrinsicTypes sym -> + CrucibleBranchTarget f a' -> + SimFrame sym ext f a' -> + IO (SimFrame sym ext f a') +abortCrucibleFrame sym intrinsicFns (BlockTarget _) (MF x') = + do r' <- abortBranchRegs sym intrinsicFns (x'^.frameRegs) + return $! MF (x' & frameRegs .~ r') + +abortCrucibleFrame sym intrinsicFns ReturnTarget (RF nm x') = + RF nm <$> abortBranchRegEntry sym intrinsicFns x' + + +abortPartialResult :: + IsSymInterface sym => + SimState p sym ext r f args -> + CrucibleBranchTarget f a' -> + PartialResultFrame sym ext f a' -> + IO (PartialResultFrame sym ext f a') +abortPartialResult s tgt pr = + let sym = s^.stateSymInterface + muxFns = s^.stateIntrinsicTypes + abtGp (GlobalPair v g) = GlobalPair <$> abortCrucibleFrame sym muxFns tgt v + <*> globalAbortBranch sym muxFns g + in partialValue abtGp pr + + +------------------------------------------------------------------------ +-- resolveCall + +-- | This exception is thrown if a 'FnHandle' cannot be resolved to +-- a callable function. This usually indicates a programming error, +-- but might also be used to allow on-demand function loading. +-- +-- The 'ProgramLoc' argument references the call site for the unresolved +-- function call. +-- +-- The @['SomeFrame']@ argument is the active call stack at the time of +-- the exception. +data UnresolvableFunction where + UnresolvableFunction :: + !(ProgramLoc) -> + [SomeFrame (SimFrame sym ext)] -> + !(FnHandle args ret) -> + UnresolvableFunction + +instance Ex.Exception UnresolvableFunction +instance Show UnresolvableFunction where + show (UnresolvableFunction loc callStack h) = + let name = show $ handleName h + in unlines $ + if "llvm" `isPrefixOf` name + then [ "Encountered unresolved LLVM intrinsic '" ++ name ++ "'" + , "Please report this on the following issue:" + , "https://github.com/GaloisInc/crucible/issues/73" + ] ++ [ show (ppExceptionContext callStack) ] + else [ "Could not resolve function: " ++ name + , "Called at: " ++ show (PP.pretty (plSourceLoc loc)) + ] ++ [ show (ppExceptionContext callStack) ] + + +-- | Utility function that packs the tail of a collection of arguments +-- into a vector of ANY type values for passing to varargs functions. +packVarargs :: + CtxRepr addlArgs -> + RegMap sym (args <+> addlArgs) -> + RegMap sym (args ::> VectorType AnyType) + +packVarargs = go mempty + where + go :: + V.Vector (AnyValue sym) -> + CtxRepr addlArgs -> + RegMap sym (args <+> addlArgs) -> + RegMap sym (args ::> VectorType AnyType) + + go v (addl Ctx.:> tp) (unconsReg -> (args, x)) = + go (V.cons (AnyValue tp (regValue x)) v) addl args + + go v Ctx.Empty args = + assignReg knownRepr v args + +-- | Given a set of function bindings, a function- +-- value (which is possibly a closure) and a +-- collection of arguments, resolve the identity +-- of the function to call, and set it up to be called. +-- +-- Will throw an 'UnresolvableFunction' exception if +-- the underlying function handle is not found in the +-- 'FunctionBindings' map. +resolveCall :: + FunctionBindings p sym ext {- ^ Map from function handles to semantics -} -> + FnVal sym args ret {- ^ Function handle and any closure variables -} -> + RegMap sym args {- ^ Arguments to the function -} -> + ProgramLoc {- ^ Location of the call -} -> + [SomeFrame (SimFrame sym ext)] {-^ current call stack (for exceptions) -} -> + ResolvedCall p sym ext ret +resolveCall bindings c0 args loc callStack = + case c0 of + ClosureFnVal c tp v -> do + resolveCall bindings c (assignReg tp v args) loc callStack + + VarargsFnVal h addlTypes -> + resolveCall bindings (HandleFnVal h) (packVarargs addlTypes args) loc callStack + + HandleFnVal h -> do + case lookupHandleMap h (fnBindings bindings) of + Nothing -> Ex.throw (UnresolvableFunction loc callStack h) + Just (UseOverride o) -> do + let f = OverrideFrame { _override = overrideName o + , _overrideHandle = SomeHandle h + , _overrideRegMap = args + } + in OverrideCall o f + Just (UseCFG g pdInfo) -> do + CrucibleCall (cfgEntryBlockID g) (mkCallFrame g pdInfo args) + + +resolvedCallName :: ResolvedCall p sym ext ret -> FunctionName +resolvedCallName (OverrideCall _ f) = f^.override +resolvedCallName (CrucibleCall _ f) = case frameHandle f of SomeHandle h -> handleName h + +--------------------------------------------------------------------- +-- Control-flow operations + +-- | Immediately transtition to an 'OverrideState'. On the next +-- execution step, the simulator will execute the given override. +runOverride :: + Override p sym ext args ret {- ^ Override to execute -} -> + ExecCont p sym ext rtp (OverrideLang ret) ('Just args) +runOverride o = ReaderT (return . OverrideState o) + +-- | Immediately transition to a 'RunningState'. On the next +-- execution step, the simulator will interpret the next basic +-- block. +continue :: RunningStateInfo blocks a -> ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just a) +continue rtgt = ReaderT (return . RunningState rtgt) + +-- | Immediately transition to an 'AbortState'. On the next +-- execution step, the simulator will unwind the 'SimState' +-- and resolve the abort. +runAbortHandler :: + AbortExecReason {- ^ Description of the abort condition -} -> + SimState p sym ext rtp f args {- ^ Simulator state prior to the abort -} -> + IO (ExecState p sym ext rtp) +runAbortHandler rsn s = return (AbortState rsn s) + +-- | Abort the current thread of execution with an error. +-- This adds a proof obligation that requires the current +-- execution path to be infeasible, and unwids to the +-- nearest branch point to resume. +runErrorHandler :: + SimErrorReason {- ^ Description of the error -} -> + SimState p sym ext rtp f args {- ^ Simulator state prior to the abort -} -> + IO (ExecState p sym ext rtp) +runErrorHandler msg st = + let ctx = st^.stateContext + sym = ctx^.ctxSymInterface + in withBackend ctx $ \bak -> + do loc <- getCurrentProgramLoc sym + let err = SimError loc msg + addProofObligation bak (LabeledPred (falsePred sym) err) + return (AbortState (AssertionFailure err) st) + +-- | Abort the current thread of execution with an error. +-- This adds a proof obligation that requires the current +-- execution path to be infeasible, and unwids to the +-- nearest branch point to resume. +runGenericErrorHandler :: + String {- ^ Generic description of the error condition -} -> + SimState p sym ext rtp f args {- ^ Simulator state prior to the abort -} -> + IO (ExecState p sym ext rtp) +runGenericErrorHandler msg st = runErrorHandler (GenericSimError msg) st + +-- | Transfer control to the given resolved jump, after first +-- checking for any pending symbolic merges at the destination +-- of the jump. +jumpToBlock :: + IsSymInterface sym => + ResolvedJump sym blocks {- ^ Jump target and arguments -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just a) +jumpToBlock jmp = ReaderT $ return . ControlTransferState (CheckMergeResumption jmp) +{-# INLINE jumpToBlock #-} + +performControlTransfer :: + IsSymInterface sym => + ControlResumption p sym ext rtp f -> + ExecCont p sym ext rtp f ('Just a) +performControlTransfer res = + case res of + ContinueResumption (ResolvedJump block_id args) -> + withReaderT + (stateCrucibleFrame %~ setFrameBlock block_id args) + (continue (RunBlockStart block_id)) + CheckMergeResumption (ResolvedJump block_id args) -> + withReaderT + (stateCrucibleFrame %~ setFrameBlock block_id args) + (checkForIntraFrameMerge (BlockTarget block_id)) + SwitchResumption cs -> + variantCases cs + OverrideResumption k args -> + withReaderT + (stateOverrideFrame.overrideRegMap .~ args) + k + +-- | Perform a conditional branch on the given predicate. +-- If the predicate is symbolic, this will record a symbolic +-- branch state. +conditionalBranch :: + (IsSymInterface sym, IsSyntaxExtension ext) => + Pred sym {- ^ Predicate to branch on -} -> + ResolvedJump sym blocks {- ^ True branch -} -> + ResolvedJump sym blocks {- ^ False branch -} -> + ExecCont p sym ext rtp (CrucibleLang blocks ret) ('Just ctx) +conditionalBranch p xjmp yjmp = do + top_frame <- view (stateTree.actFrame) + Some pd <- return (top_frame^.crucibleTopFrame.framePostdom) + + x_frame <- cruciblePausedFrame xjmp top_frame pd + y_frame <- cruciblePausedFrame yjmp top_frame pd + + intra_branch p x_frame y_frame pd + +-- | Execute the next branch of a sequence of branch cases. +-- These arise from the implementation of the 'VariantElim' +-- construct. The predicates are expected to be mutually +-- disjoint. However, the construct still has well defined +-- semantics even in the case where they overlap; in this case, +-- the first branch with a true 'Pred' is taken. In other words, +-- each branch assumes the negation of all the predicates of branches +-- appearing before it. +-- +-- In the final default case (corresponding to an empty list of branches), +-- a 'VariantOptionsExhausted' abort will be executed. +variantCases :: + IsSymInterface sym => + [(Pred sym, ResolvedJump sym blocks)] {- ^ Variant branches to execute -} -> + ExecCont p sym ext rtp (CrucibleLang blocks r) ('Just ctx) + +variantCases [] = + do fm <- view stateCrucibleFrame + let loc = frameProgramLoc fm + let rsn = VariantOptionsExhausted loc + abortExec rsn + +variantCases ((p,jmp) : cs) = + do top_frame <- view (stateTree.actFrame) + Some pd <- return (top_frame^.crucibleTopFrame.framePostdom) + + x_frame <- cruciblePausedFrame jmp top_frame pd + let y_frame = PausedFrame (TotalRes top_frame) (SwitchResumption cs) Nothing + + intra_branch p x_frame y_frame pd + +-- | Return a value from current Crucible execution. +returnValue :: forall p sym ext rtp f args. + RegEntry sym (FrameRetType f) {- ^ return value -} -> + ExecCont p sym ext rtp f args +returnValue arg = + do nm <- view (stateTree.actFrame.gpValue.frameFunctionName) + withReaderT + (stateTree.actFrame.gpValue .~ RF nm arg) + (checkForIntraFrameMerge ReturnTarget) + + +callFunction :: + IsExprBuilder sym => + FnVal sym args ret {- ^ Function handle and any closure variables -} -> + RegMap sym args {- ^ Arguments to the function -} -> + ReturnHandler ret p sym ext rtp f a {- ^ How to modify the caller's scope with the return value -} -> + ProgramLoc {-^ location of call -} -> + ExecCont p sym ext rtp f a +callFunction fn args retHandler loc = + do bindings <- view (stateContext.functionBindings) + callStack <- view (stateTree . to activeFrames) + let rcall = resolveCall bindings fn args loc callStack + ReaderT $ return . CallState retHandler rcall + +tailCallFunction :: + FrameRetType f ~ ret => + FnVal sym args ret {- ^ Function handle and any closure variables -} -> + RegMap sym args {- ^ Arguments to the function -} -> + ValueFromValue p sym ext rtp ret -> + ProgramLoc {-^ location of call -} -> + ExecCont p sym ext rtp f a +tailCallFunction fn args vfv loc = + do bindings <- view (stateContext.functionBindings) + callStack <- view (stateTree . to activeFrames) + let rcall = resolveCall bindings fn args loc callStack + ReaderT $ return . TailCallState vfv rcall + + +-- | Immediately transition to the 'BranchMergeState'. +-- On the next simulator step, this will checks for the +-- opportunity to merge within a frame. +-- +-- This should be called everytime the current control flow location +-- changes to a potential merge point. +checkForIntraFrameMerge :: + CrucibleBranchTarget f args + {- ^ The location of the block we are transferring to -} -> + ExecCont p sym ext root f args + +checkForIntraFrameMerge tgt = + ReaderT $ return . BranchMergeState tgt + + +assumeInNewFrame :: + IsSymBackend sym bak => + bak -> + Assumption sym -> + IO FrameIdentifier +assumeInNewFrame bak asm = + do frm <- pushAssumptionFrame bak + Ex.try @Ex.SomeException (addAssumption bak asm) >>= \case + Left ex -> + do void $ popAssumptionFrame bak frm + Ex.throw ex + Right () -> return frm + +-- | Perform a single instance of path merging at a join point. +-- This will resume an alternate branch, if it is pending, +-- or merge result values if a completed branch has alread reached +-- this point. If there are no pending merge points at this location, +-- continue executing by transfering control to the given target. +performIntraFrameMerge :: + IsSymInterface sym => + CrucibleBranchTarget f args + {- ^ The location of the block we are transferring to -} -> + ExecCont p sym ext root f args + +performIntraFrameMerge tgt = do + ActiveTree ctx0 er <- view stateTree + simCtx <- view stateContext + sym <- view stateSymInterface + withBackend simCtx $ \bak -> + case ctx0 of + VFFBranch ctx assume_frame loc pred other_branch tgt' + + -- Did we get to our merge point (i.e., we are finished with this branch) + | Just Refl <- testEquality tgt tgt' -> + case other_branch of + + -- We still have some more work to do, reactivate the other, postponed branch + VFFActivePath next -> + do pathAssumes <- liftIO $ popAssumptionFrame bak assume_frame + pnot <- liftIO $ notPred sym pred + new_assume_frame <- + liftIO $ assumeInNewFrame bak (BranchCondition loc (pausedLoc next) pnot) + + -- The current branch is done + let new_other = VFFCompletePath pathAssumes er + resumeFrame next (VFFBranch ctx new_assume_frame loc pnot new_other tgt) + + -- We are done with both branches, pop-off back to the outer context. + VFFCompletePath otherAssumes other -> + do ar <- ReaderT $ \s -> + mergePartialResult s tgt pred er other + + -- Merge the assumptions from each branch and add to the + -- current assumption frame + pathAssumes <- liftIO $ popAssumptionFrame bak assume_frame + + liftIO $ addAssumptions bak + =<< mergeAssumptions sym pred pathAssumes otherAssumes + + -- Check for more potential merge targets. + withReaderT + (stateTree .~ ActiveTree ctx ar) + (checkForIntraFrameMerge tgt) + + -- Since the other branch aborted before it got to the merge point, + -- we merge-in the partiality on our current path and keep going. + VFFPartial ctx loc pred ar needsAborting -> + do er' <- case needsAborting of + NoNeedToAbort -> return er + NeedsToBeAborted -> ReaderT $ \s -> abortPartialResult s tgt er + er'' <- liftIO $ + mergePartialAndAbortedResult sym loc pred er' ar + withReaderT + (stateTree .~ ActiveTree ctx er'') + (checkForIntraFrameMerge tgt) + + -- There are no pending merges to deal with. Instead, complete + -- the transfer of control by either transitioning into an ordinary + -- running state, or by returning a value to the calling context. + _ -> case tgt of + BlockTarget bid -> + continue (RunPostBranchMerge bid) + ReturnTarget -> + handleSimReturn + (er^.partialValue.gpValue.frameFunctionName) + (returnContext ctx0) + (er^.partialValue.gpValue.to fromReturnFrame) + +--------------------------------------------------------------------- +-- Abort handling + +-- | The default abort handler calls `abortExecAndLog`. +defaultAbortHandler :: IsSymInterface sym => AbortHandler p sym ext rtp +defaultAbortHandler = AH abortExecAndLog + +-- | Abort the current execution and roll back to the nearest +-- symbolic branch point. When verbosity is 3 or more, a message +-- will be logged indicating the reason for the abort. +-- +-- The default abort handler calls this function. +abortExecAndLog :: + IsSymInterface sym => + AbortExecReason -> + ExecCont p sym ext rtp f args +abortExecAndLog rsn = do + t <- view stateTree + cfg <- view stateConfiguration + ctx <- view stateContext + v <- liftIO (getOpt =<< getOptionSetting verbosity cfg) + when (v >= 3) $ do + let frames = activeFrames t + let msg = PP.vcat [ ppAbortExecReason rsn + , PP.indent 2 (ppExceptionContext frames) ] + -- Print error message. + liftIO (hPrint (printHandle ctx) msg) + + -- Switch to new frame. + abortExec rsn + + +-- | Abort the current execution and roll back to the nearest +-- symbolic branch point. +abortExec :: + IsSymInterface sym => + AbortExecReason -> + ExecCont p sym ext rtp f args +abortExec rsn = do + ActiveTree ctx ar0 <- view stateTree + resumeValueFromFrameAbort ctx $ + -- Get aborted result from active result. + case ar0 of + TotalRes e -> AbortedExec rsn e + PartialRes loc pred ex ar1 -> + AbortedBranch loc pred (AbortedExec rsn ex) ar1 + + +------------------------------------------------------------------------ +-- Internal operations + +-- | Resolve the fact that the current branch aborted. +resumeValueFromFrameAbort :: + IsSymInterface sym => + ValueFromFrame p sym ext r f -> + AbortedResult sym ext {- ^ The execution that is being aborted. -} -> + ExecCont p sym ext r g args +resumeValueFromFrameAbort ctx0 ar0 = do + simCtx <- view stateContext + sym <- view stateSymInterface + withBackend simCtx $ \bak -> + case ctx0 of + + -- This is the first abort. + VFFBranch ctx assume_frame loc pred other_branch tgt -> + do pnot <- liftIO $ notPred sym pred + let nextCtx = VFFPartial ctx loc pnot ar0 NeedsToBeAborted + + -- Reset the backend path state + _assumes <- liftIO $ popAssumptionFrame bak assume_frame + + case other_branch of + + -- We have some more work to do. + VFFActivePath n -> + do liftIO $ addAssumption bak (BranchCondition loc (pausedLoc n) pnot) + resumeFrame n nextCtx + + -- The other branch had finished successfully; + -- Since this one aborted, then the other one is really the only + -- viable option we have, and so we commit to it. + VFFCompletePath otherAssumes er -> + do -- We are committed to the other path, + -- assume all of its suspended assumptions + liftIO $ addAssumptions bak otherAssumes + + -- check for further merges, then continue onward. + withReaderT + (stateTree .~ ActiveTree nextCtx er) + (checkForIntraFrameMerge tgt) + + -- Both branches aborted + VFFPartial ctx loc pred ay _ -> + resumeValueFromFrameAbort ctx $ AbortedBranch loc pred ar0 ay + + VFFEnd ctx -> + ReaderT $ return . UnwindCallState ctx ar0 + +-- | Run rest of execution given a value from value context and an aborted +-- result. +resumeValueFromValueAbort :: + IsSymInterface sym => + ValueFromValue p sym ext r ret' -> + AbortedResult sym ext -> + ExecCont p sym ext r f a +resumeValueFromValueAbort ctx0 ar0 = + case ctx0 of + VFVCall ctx frm _rh -> + do ActiveTree _oldFrm er <- view stateTree + withReaderT + (stateTree .~ ActiveTree ctx (er & partialValue.gpValue .~ frm)) + (resumeValueFromFrameAbort ctx ar0) + VFVPartial ctx loc pred ay -> do + resumeValueFromValueAbort ctx (AbortedBranch loc pred ar0 ay) + VFVEnd -> + do res <- view stateContext + return $! ResultState $ AbortedResult res ar0 + +-- | Resume a paused frame. +resumeFrame :: + IsSymInterface sym => + PausedFrame p sym ext rtp f -> + ValueFromFrame p sym ext rtp f -> + ExecCont p sym ext rtp g ba +resumeFrame (PausedFrame frm cont toLoc) ctx = + do case toLoc of + Nothing -> return () + Just l -> + do sym <- view stateSymInterface + liftIO $ setCurrentProgramLoc sym l + withReaderT + (stateTree .~ ActiveTree ctx frm) + (ReaderT $ return . ControlTransferState cont) +{-# INLINABLE resumeFrame #-} + + +-- | Transition immediately to a @ReturnState@. We are done with all +-- intercall merges, and are ready to resmue execution in the caller's +-- context. +handleSimReturn :: + IsSymInterface sym => + FunctionName {- ^ Name of the function we are returning from -} -> + ValueFromValue p sym ext r ret {- ^ Context to return to. -} -> + RegEntry sym ret {- ^ Value that is being returned. -} -> + ExecCont p sym ext r f a +handleSimReturn fnName vfv return_value = + ReaderT $ return . ReturnState fnName vfv return_value + + +-- | Resolve the return value, and begin executing in the caller's context again. +performReturn :: + IsSymInterface sym => + FunctionName {- ^ Name of the function we are returning from -} -> + ValueFromValue p sym ext r ret {- ^ Context to return to. -} -> + RegEntry sym ret {- ^ Value that is being returned. -} -> + ExecCont p sym ext r f a +performReturn fnName ctx0 v = do + case ctx0 of + VFVCall ctx (MF f) (ReturnToCrucible tpr rest) -> + do ActiveTree _oldctx pres <- view stateTree + let f' = extendFrame tpr (regValue v) rest f + withReaderT + (stateTree .~ ActiveTree ctx (pres & partialValue . gpValue .~ MF f')) + (continue (RunReturnFrom fnName)) + + VFVCall ctx _ TailReturnToCrucible -> + do ActiveTree _oldctx pres <- view stateTree + withReaderT + (stateTree .~ ActiveTree ctx (pres & partialValue . gpValue .~ RF fnName v)) + (returnValue v) + + VFVCall ctx (OF f) (ReturnToOverride k) -> + do ActiveTree _oldctx pres <- view stateTree + withReaderT + (stateTree .~ ActiveTree ctx (pres & partialValue . gpValue .~ OF f)) + (ReaderT (k v)) + + VFVPartial ctx loc pred r -> + do sym <- view stateSymInterface + ActiveTree oldctx pres <- view stateTree + newPres <- liftIO $ + mergePartialAndAbortedResult sym loc pred pres r + withReaderT + (stateTree .~ ActiveTree oldctx newPres) + (performReturn fnName ctx v) + + VFVEnd -> + do simctx <- view stateContext + ActiveTree _oldctx pres <- view stateTree + return $! ResultState $ FinishedResult simctx (pres & partialValue . gpValue .~ v) + +cruciblePausedFrame :: + ResolvedJump sym b -> + GlobalPair sym (SimFrame sym ext (CrucibleLang b r) ('Just a)) -> + CrucibleBranchTarget (CrucibleLang b r) pd_args {- ^ postdominator target -} -> + ReaderT (SimState p sym ext rtp (CrucibleLang b z) ('Just dc_args)) IO + (PausedFrame p sym ext rtp' (CrucibleLang b r)) +cruciblePausedFrame jmp@(ResolvedJump x_id _) top_frame pd = + do let res = case testEquality pd (BlockTarget x_id) of + Just Refl -> CheckMergeResumption jmp + Nothing -> ContinueResumption jmp + loc <- getTgtLoc x_id + return $ PausedFrame (TotalRes top_frame) res (Just loc) + +overrideSymbolicBranch :: + IsSymInterface sym => + Pred sym -> + + RegMap sym then_args -> + ExecCont p sym ext rtp (OverrideLang r) ('Just then_args) {- ^ if branch -} -> + Maybe Position {- ^ optional if branch location -} -> + + RegMap sym else_args -> + ExecCont p sym ext rtp (OverrideLang r) ('Just else_args) {- ^ else branch -} -> + Maybe Position {- ^ optional else branch location -} -> + + ExecCont p sym ext rtp (OverrideLang r) ('Just args) +overrideSymbolicBranch p thn_args thn thn_pos els_args els els_pos = + do top_frm <- view (stateTree.actFrame) + let fnm = top_frm^.gpValue.overrideSimFrame.override + let thn_loc = mkProgramLoc fnm <$> thn_pos + let els_loc = mkProgramLoc fnm <$> els_pos + let thn_frm = PausedFrame (TotalRes top_frm) (OverrideResumption thn thn_args) thn_loc + let els_frm = PausedFrame (TotalRes top_frm) (OverrideResumption els els_args) els_loc + intra_branch p thn_frm els_frm ReturnTarget + +getTgtLoc :: + BlockID b y -> + ReaderT (SimState p sym ext r (CrucibleLang b a) ('Just dc_args)) IO ProgramLoc +getTgtLoc (BlockID i) = + do blocks <- view (stateCrucibleFrame . to frameBlockMap) + return $ blockLoc (blocks Ctx.! i) + +-- | Return the context of the current top frame. +asContFrame :: + ActiveTree p sym ext ret f args -> + ValueFromFrame p sym ext ret f +asContFrame (ActiveTree ctx active_res) = + case active_res of + TotalRes{} -> ctx + PartialRes loc pred _ex ar -> VFFPartial ctx loc pred ar NoNeedToAbort + + +-- | Return assertion where predicate equals a constant +predEqConst :: IsExprBuilder sym => sym -> Pred sym -> Bool -> IO (Pred sym) +predEqConst _ p True = return p +predEqConst sym p False = notPred sym p + +-- | Branch with a merge point inside this frame. +intra_branch :: + IsSymInterface sym => + Pred sym + {- ^ Branch condition branch -} -> + + PausedFrame p sym ext rtp f + {- ^ true branch. -} -> + + PausedFrame p sym ext rtp f + {- ^ false branch. -} -> + + CrucibleBranchTarget f (args :: Maybe (Ctx CrucibleType)) + {- ^ Postdominator merge point, where both branches meet again. -} -> + + ExecCont p sym ext rtp f ('Just dc_args) + +intra_branch p t_label f_label tgt = do + ctx <- asContFrame <$> view stateTree + simCtx <- view stateContext + sym <- view stateSymInterface + withBackend simCtx $ \bak -> + case asConstantPred p of + Nothing -> + ReaderT $ return . SymbolicBranchState p t_label f_label tgt + + Just chosen_branch -> + do p' <- liftIO $ predEqConst sym p chosen_branch + let a_frame = if chosen_branch then t_label else f_label + loc <- liftIO $ getCurrentProgramLoc sym + liftIO $ addAssumption bak (BranchCondition loc (pausedLoc a_frame) p') + resumeFrame a_frame ctx +{-# INLINABLE intra_branch #-} + +-- | Branch with a merge point inside this frame. +performIntraFrameSplit :: + IsSymInterface sym => + Pred sym + {- ^ Branch condition -} -> + + PausedFrame p sym ext rtp f + {- ^ active branch. -} -> + + PausedFrame p sym ext rtp f + {- ^ other branch. -} -> + + CrucibleBranchTarget f (args :: Maybe (Ctx CrucibleType)) + {- ^ Postdominator merge point, where both branches meet again. -} -> + + ExecCont p sym ext rtp f ('Just dc_args) +performIntraFrameSplit p a_frame o_frame tgt = + do ctx <- asContFrame <$> view stateTree + simCtx <- view stateContext + sym <- view stateSymInterface + loc <- liftIO $ getCurrentProgramLoc sym + a_frame' <- pushPausedFrame a_frame + o_frame' <- pushPausedFrame o_frame + + assume_frame <- withBackend simCtx $ \bak -> + liftIO $ assumeInNewFrame bak (BranchCondition loc (pausedLoc a_frame') p) + + -- Create context for paused frame. + let todo = VFFActivePath o_frame' + ctx' = VFFBranch ctx assume_frame loc p todo tgt + + -- Start a_state (where branch pred is p) + resumeFrame a_frame' ctx' + +performFunctionCall :: + IsSymInterface sym => + ReturnHandler ret p sym ext rtp outer_frame outer_args -> + ResolvedCall p sym ext ret -> + ExecCont p sym ext rtp outer_frame outer_args +performFunctionCall retHandler frm = + do sym <- view stateSymInterface + case frm of + OverrideCall o f -> + -- Eventually, locations should be nested. However, for now, + -- while they're not, it's useful for the location of an + -- override to be the location of its call site, so we don't + -- change it here. + withReaderT + (stateTree %~ pushCallFrame retHandler (OF f)) + (runOverride o) + CrucibleCall entryID f -> do + let loc = mkProgramLoc (resolvedCallName frm) (OtherPos "") + liftIO $ setCurrentProgramLoc sym loc + withReaderT + (stateTree %~ pushCallFrame retHandler (MF f)) + (continue (RunBlockStart entryID)) + +performTailCall :: + IsSymInterface sym => + ValueFromValue p sym ext rtp ret -> + ResolvedCall p sym ext ret -> + ExecCont p sym ext rtp f a +performTailCall vfv frm = + do sym <- view stateSymInterface + let loc = mkProgramLoc (resolvedCallName frm) (OtherPos "") + liftIO $ setCurrentProgramLoc sym loc + case frm of + OverrideCall o f -> + withReaderT + (stateTree %~ swapCallFrame vfv (OF f)) + (runOverride o) + CrucibleCall entryID f -> + withReaderT + (stateTree %~ swapCallFrame vfv (MF f)) + (continue (RunBlockStart entryID)) + +------------------------------------------------------------------------ +-- Context tree manipulations + +-- | Returns true if tree contains a single non-aborted execution. +isSingleCont :: ValueFromFrame p sym ext root a -> Bool +isSingleCont c0 = + case c0 of + VFFBranch{} -> False + VFFPartial c _ _ _ _ -> isSingleCont c + VFFEnd vfv -> isSingleVFV vfv + +isSingleVFV :: ValueFromValue p sym ext r a -> Bool +isSingleVFV c0 = do + case c0 of + VFVCall c _ _ -> isSingleCont c + VFVPartial c _ _ _ -> isSingleVFV c + VFVEnd -> True + +-- | Attempt to unwind a frame context into a value context. +-- This succeeds only if there are no pending symbolic +-- merges. +unwindContext :: + ValueFromFrame p sym ext root f -> + Maybe (ValueFromValue p sym ext root (FrameRetType f)) +unwindContext c0 = + case c0 of + VFFBranch{} -> Nothing + VFFPartial _ _ _ _ NeedsToBeAborted -> Nothing + VFFPartial d loc pred ar NoNeedToAbort -> + (\d' -> VFVPartial d' loc pred ar) <$> unwindContext d + VFFEnd vfv -> return vfv + +-- | Get the context for when returning (assumes no +-- intra-procedural merges are possible). +returnContext :: + ValueFromFrame ctx sym ext root f -> + ValueFromValue ctx sym ext root (FrameRetType f) +returnContext c0 = + fromMaybe + (panic "ExecutionTree.returnContext" + [ "Unexpected attempt to exit function before all intra-procedural merges are complete." + , "The call stack was:" + , show (PP.pretty c0) + ]) + (unwindContext c0) + +-- | Replace the given frame with a new frame. Succeeds +-- only if there are no pending symbolic merge points. +replaceTailFrame :: forall p sym ext a b c args args'. + FrameRetType a ~ FrameRetType c => + ActiveTree p sym ext b a args -> + SimFrame sym ext c args' -> + Maybe (ActiveTree p sym ext b c args') +replaceTailFrame t@(ActiveTree c _) f = do + vfv <- unwindContext c + return $ swapCallFrame vfv f t + +swapCallFrame :: + ValueFromValue p sym ext rtp (FrameRetType f') -> + SimFrame sym ext f' args' -> + ActiveTree p sym ext rtp f args -> + ActiveTree p sym ext rtp f' args' +swapCallFrame vfv frm (ActiveTree _ er) = + ActiveTree (VFFEnd vfv) (er & partialValue . gpValue .~ frm) + + +pushCallFrame :: + ReturnHandler (FrameRetType a) p sym ext r f old_args + {- ^ What to do with the result of the function -} -> + + SimFrame sym ext a args + {- ^ The code to run -} -> + + ActiveTree p sym ext r f old_args -> + ActiveTree p sym ext r a args +pushCallFrame rh f' (ActiveTree ctx er) = + ActiveTree (VFFEnd (VFVCall ctx old_frame rh)) er' + where + old_frame = er ^. partialValue ^. gpValue + er' = er & partialValue . gpValue .~ f' + + +-- | Create a tree that contains just a single path with no branches. +-- +-- All branch conditions are converted to assertions. +extractCurrentPath :: + ActiveTree p sym ext ret f args -> + ActiveTree p sym ext ret f args +extractCurrentPath t = + ActiveTree (vffSingleContext (t^.actContext)) + (TotalRes (t^.actFrame)) + +vffSingleContext :: + ValueFromFrame p sym ext ret f -> + ValueFromFrame p sym ext ret f +vffSingleContext ctx0 = + case ctx0 of + VFFBranch ctx _ _ _ _ _ -> vffSingleContext ctx + VFFPartial ctx _ _ _ _ -> vffSingleContext ctx + VFFEnd ctx -> VFFEnd (vfvSingleContext ctx) + +vfvSingleContext :: + ValueFromValue p sym ext root top_ret -> + ValueFromValue p sym ext root top_ret +vfvSingleContext ctx0 = + case ctx0 of + VFVCall ctx f h -> VFVCall (vffSingleContext ctx) f h + VFVPartial ctx _ _ _ -> vfvSingleContext ctx + VFVEnd -> VFVEnd + + +------------------------------------------------------------------------ +-- branchConditions + +-- -- | Return all branch conditions along path to this node. +-- branchConditions :: ActiveTree ctx sym ext ret f args -> [Pred sym] +-- branchConditions t = +-- case t^.actResult of +-- TotalRes _ -> vffBranchConditions (t^.actContext) +-- PartialRes p _ _ -> p : vffBranchConditions (t^.actContext) + +-- vffBranchConditions :: ValueFromFrame p sym ext ret f +-- -> [Pred sym] +-- vffBranchConditions ctx0 = +-- case ctx0 of +-- VFFBranch ctx _ _ p _ _ -> p : vffBranchConditions ctx +-- VFFPartial ctx p _ _ -> p : vffBranchConditions ctx +-- VFFEnd ctx -> vfvBranchConditions ctx + +-- vfvBranchConditions :: ValueFromValue p sym ext root top_ret +-- -> [Pred sym] +-- vfvBranchConditions ctx0 = +-- case ctx0 of +-- VFVCall ctx _ _ -> vffBranchConditions ctx +-- VFVPartial ctx p _ -> p : vfvBranchConditions ctx +-- VFVEnd -> [] diff --git a/src/Lang/Crucible/Simulator/OverrideSim.hs b/src/Lang/Crucible/Simulator/OverrideSim.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/OverrideSim.hs @@ -0,0 +1,705 @@ +{-| +Module : Lang.Crucible.Simulator.OverrideSim +Description : The main simulation monad +Copyright : (c) Galois, Inc 2014-2018 +License : BSD3 +Maintainer : Joe Hendrix + +Define the main simulation monad 'OverrideSim' and basic operations on it. +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.OverrideSim + ( -- * Monad definition + OverrideSim(..) + , runOverrideSim + -- * Monad operations + , withSimContext + , getContext + , getSymInterface + , ovrWithBackend + , bindFnHandle + , bindCFG + , exitExecution + , getOverrideArgs + , overrideError + , overrideAbort + , symbolicBranch + , symbolicBranches + , nondetBranches + , overrideReturn + , overrideReturn' + -- * Function calls + , callFnVal + , callFnVal' + , callCFG + , callBlock + , callOverride + -- * Global variables + , readGlobal + , writeGlobal + , readGlobals + , writeGlobals + , modifyGlobal + -- * References + , newRef + , newEmptyRef + , readRef + , writeRef + , modifyRef + , readMuxTreeRef + , writeMuxTreeRef + -- * Function bindings + , FnBinding(..) + , fnBindingsFromList + , registerFnBinding + , AnyFnBindings(..) + -- * Overrides + , mkOverride + , mkOverride' + -- * Intrinsic implementations + , IntrinsicImpl + , mkIntrinsic + , useIntrinsic + -- * Typed overrides + , TypedOverride(..) + , SomeTypedOverride(..) + , runTypedOverride + -- * Re-exports + , Lang.Crucible.Simulator.ExecutionTree.Override + ) where + +import Control.Exception +import Control.Lens +import Control.Monad hiding (fail) +import qualified Control.Monad.Catch as X +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.ST +import Control.Monad.State.Strict (StateT(..)) +import Data.List (foldl') +import qualified Data.Parameterized.Context as Ctx +import Data.Proxy +import qualified Data.Text as T +import Data.Traversable (for) +import Numeric.Natural (Natural) +import System.Exit +import System.IO +import System.IO.Error + +import Data.Parameterized.TraversableFC (fmapFC) + +import What4.Config +import What4.Interface +import What4.FunctionName +import What4.Partial (justPartExpr) +import What4.ProgramLoc +import What4.Utils.MonadST + +import Lang.Crucible.Analysis.Postdom +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Extension +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Panic(panic) + +import Lang.Crucible.Backend +import Lang.Crucible.Simulator.CallFrame +import qualified Lang.Crucible.Simulator.EvalStmt as EvalStmt (readRef, alterRef) +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Operations + ( runGenericErrorHandler, runErrorHandler, runAbortHandler + , returnValue, callFunction, overrideSymbolicBranch ) +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Utils.MonadVerbosity +import Lang.Crucible.Utils.MuxTree (MuxTree) +import Lang.Crucible.Utils.StateContT + +------------------------------------------------------------------------ +-- OverrideSim + +-- | Monad for running symbolic simulator. +-- +-- Type parameters: +-- +-- * 'p' the "personality", i.e. user-defined state parameterized by @sym@ +-- * 'sym' the symbolic backend +-- * 'ext' the syntax extension ("Lang.Crucible.CFG.Extension") +-- * 'rtp' global return type +-- * 'args' argument types for the current frame +-- * 'ret' return type of the current frame +-- * 'a' the value type +-- +newtype OverrideSim p sym ext rtp (args :: Ctx CrucibleType) (ret :: CrucibleType) a + = Sim { unSim :: StateContT (SimState p sym ext rtp (OverrideLang ret) ('Just args)) + (ExecState p sym ext rtp) + IO + a + } + deriving ( Functor + , Applicative + ) + +-- | Exit from the current execution by ignoring the continuation +-- and immediately returning an aborted execution result. +exitExecution :: IsSymInterface sym => ExitCode -> OverrideSim p sym ext rtp args r a +exitExecution ec = Sim $ StateContT $ \_c s -> + return $ ResultState $ AbortedResult (s^.stateContext) (AbortedExit ec) + +bindOverrideSim :: + OverrideSim p sym ext rtp args r a -> + (a -> OverrideSim p sym ext rtp args r b) -> + OverrideSim p sym ext rtp args r b +bindOverrideSim (Sim m) h = Sim $ unSim . h =<< m +{-# INLINE bindOverrideSim #-} + +instance Monad (OverrideSim p sym ext rtp args r) where + (>>=) = bindOverrideSim + +deriving instance MonadState (SimState p sym ext rtp (OverrideLang ret) ('Just args)) + (OverrideSim p sym ext rtp args ret) + +instance MonadFail (OverrideSim p sym ext rtp args ret) where + fail msg = Sim $ StateContT $ \_c -> runGenericErrorHandler msg + + +instance MonadIO (OverrideSim p sym ext rtp args ret) where + liftIO m = do + Sim $ StateContT $ \c s -> do + -- FIXME, should we be doing this exception handling here, or should + -- we just continue to let it bubble upward? + r <- try m + case r of + Left e0 + -- IO Exception + | Just e <- fromException e0 + , isUserError e -> + runGenericErrorHandler (ioeGetErrorString e) s + -- AbortReason + | Just e <- fromException e0 -> + runAbortHandler e s + -- Default case + | otherwise -> + throwIO e0 + Right v -> c v s + +instance MonadST RealWorld (OverrideSim p sym ext rtp args ret) where + liftST m = liftIO $ stToIO m + +instance MonadCont (OverrideSim p sym ext rtp args ret) where + callCC f = Sim $ callCC (\k -> unSim (f (\a -> Sim (k a)))) + +instance X.MonadThrow (OverrideSim p sym ext rtp args ret) where + throwM = liftIO . throwIO + +getContext :: OverrideSim p sym ext rtp args ret (SimContext p sym ext) +getContext = use stateContext +{-# INLINE getContext #-} + +getSymInterface :: OverrideSim p sym ext rtp args ret sym +getSymInterface = use stateSymInterface + +ovrWithBackend :: + (forall bak. IsSymBackend sym bak => bak -> OverrideSim p sym ext rtp args ret a) -> + OverrideSim p sym ext rtp args ret a +ovrWithBackend k = + do simCtx <- use stateContext + ctxSolverProof simCtx (withBackend simCtx k) + +instance MonadVerbosity (OverrideSim p sym ext rtp args ret) where + getVerbosity = + do ctx <- getContext + let cfg = ctxSolverProof ctx (getConfiguration (ctx^.ctxSymInterface)) + v <- liftIO (getOpt =<< getOptionSetting verbosity cfg) + return (fromInteger v) + + getLogFunction = + do h <- printHandle <$> getContext + verb <- getVerbosity + return $ \n msg -> do + when (n <= verb) $ do + hPutStr h msg + hFlush h + showWarning msg = + do h <- printHandle <$> getContext + liftIO $ + do hPutStrLn h msg + hFlush h + +-- | Associate a definition (either an 'Override' or a 'CFG') with the given handle. +bindFnHandle :: + FnHandle args ret -> + FnState p sym ext args ret -> + OverrideSim p sym ext rtp a r () +bindFnHandle h s = + stateContext . functionBindings %= FnBindings . insertHandleMap h s . fnBindings + +-- | Bind a CFG to its handle. +-- +-- Computes postdominator information. +bindCFG :: CFG ext blocks args ret -> OverrideSim p sym ext rtp a r () +bindCFG c = bindFnHandle (cfgHandle c) (UseCFG c (postdomInfo c)) + +------------------------------------------------------------------------ +-- Mutable variables + +-- | Read the whole sym global state. +readGlobals :: OverrideSim p sym ext rtp args ret (SymGlobalState sym) +readGlobals = use (stateTree . actFrame . gpGlobals) + +-- | Overwrite the whole sym global state +writeGlobals :: SymGlobalState sym -> OverrideSim p sym ext rtp args ret () +writeGlobals g = stateTree . actFrame . gpGlobals .= g + +-- | Read a particular global variable from the global variable state. +readGlobal :: + IsSymInterface sym => + GlobalVar tp {- ^ global variable -} -> + OverrideSim p sym ext rtp args ret (RegValue sym tp) {- ^ current value -} +readGlobal k = + do globals <- use (stateTree . actFrame . gpGlobals) + case lookupGlobal k globals of + Just v -> return v + Nothing -> panic "OverrideSim.readGlobal" + [ "Attempt to read undefined global." + , "*** Global name: " ++ show k + ] + +-- | Set the value of a particular global variable. +writeGlobal :: + GlobalVar tp {- ^ global variable -} -> + RegValue sym tp {- ^ new value -} -> + OverrideSim p sym ext rtp args ret () +writeGlobal g v = stateTree . actFrame . gpGlobals %= insertGlobal g v + + +-- | Run an action to compute the new value of a global. +modifyGlobal :: + IsSymInterface sym => + GlobalVar tp {- ^ global variable to modify -} -> + (RegValue sym tp -> + OverrideSim p sym ext rtp args ret (a, RegValue sym tp)) {- ^ modification action -} -> + OverrideSim p sym ext rtp args ret a +modifyGlobal gv f = + do x <- readGlobal gv + (a, x') <- f x + writeGlobal gv x' + return a + +-- | Create a new reference cell. +newRef :: + IsSymInterface sym => + TypeRepr tp {- ^ Type of the reference cell -} -> + RegValue sym tp {- ^ Initial value of the cell -} -> + OverrideSim p sym ext rtp args ret (RefCell tp) +newRef tpr v = + do r <- newEmptyRef tpr + writeRef r v + return r + +-- | Create a new reference cell with no contents. +newEmptyRef :: + TypeRepr tp {- ^ Type of the reference cell -} -> + OverrideSim p sym ext rtp args ret (RefCell tp) +newEmptyRef tpr = + do halloc <- use (stateContext . to simHandleAllocator) + liftIO $ freshRefCell halloc tpr + +-- | Read the current value of a reference cell. +readRef :: + IsSymInterface sym => + RefCell tp {- ^ Reference cell to read -} -> + OverrideSim p sym ext rtp args ret (RegValue sym tp) +readRef r = + do globals <- use (stateTree . actFrame . gpGlobals) + let msg = ReadBeforeWriteSimError "Attempt to read undefined reference cell" + ovrWithBackend $ \bak -> + liftIO $ readPartExpr bak (lookupRef r globals) msg + +-- | Write a value into a reference cell. +writeRef :: + IsSymInterface sym => + RefCell tp {- ^ Reference cell to write -} -> + RegValue sym tp {- ^ Value to write into the cell -} -> + OverrideSim p sym ext rtp args ret () +writeRef r v = + do sym <- getSymInterface + stateTree . actFrame . gpGlobals %= insertRef sym r v + +modifyRef :: + IsSymInterface sym => + RefCell tp {- ^ Reference cell to modify -} -> + (RegValue sym tp -> + OverrideSim p sym ext rtp args ret (a, RegValue sym tp)) {- ^ modification action -} -> + OverrideSim p sym ext rtp args ret a +modifyRef ref f = + do x <- readRef ref + (a, x') <- f x + writeRef ref x' + return a + + +-- | Read the current value of a mux tree of reference cells. +readMuxTreeRef :: + IsSymInterface sym => + TypeRepr tp -> + MuxTree sym (RefCell tp) {- ^ Reference cell to read -} -> + OverrideSim p sym ext rtp args ret (RegValue sym tp) +readMuxTreeRef tpr r = + do iTypes <- ctxIntrinsicTypes <$> use stateContext + globals <- use (stateTree . actFrame . gpGlobals) + ovrWithBackend $ \bak -> + liftIO $ EvalStmt.readRef bak iTypes tpr r globals + +-- | Write a value into a mux tree of reference cells. +writeMuxTreeRef :: + IsSymInterface sym => + TypeRepr tp -> + MuxTree sym (RefCell tp) {- ^ Reference cell to write -} -> + RegValue sym tp {- ^ Value to write into the cell -} -> + OverrideSim p sym ext rtp args ret () +writeMuxTreeRef tpr r v = + do sym <- getSymInterface + iTypes <- ctxIntrinsicTypes <$> use stateContext + globals <- use (stateTree . actFrame . gpGlobals) + globals' <- liftIO $ EvalStmt.alterRef sym iTypes tpr r (justPartExpr sym v) globals + stateTree . actFrame . gpGlobals .= globals' + + +-- | Turn an 'OverrideSim' action into an 'ExecCont' that can be executed +-- using standard Crucible execution primitives like 'executeCrucible'. +runOverrideSim :: + TypeRepr tp {- ^ return type -} -> + OverrideSim p sym ext rtp args tp (RegValue sym tp) {- ^ action to execute -} -> + ExecCont p sym ext rtp (OverrideLang tp) ('Just args) +runOverrideSim tp m = ReaderT $ \s0 -> stateSolverProof s0 $ + runStateContT (unSim m) (\v -> runReaderT (returnValue (RegEntry tp v))) s0 + + +-- | Create an override from an explicit return type and definition using 'OverrideSim'. +mkOverride' :: + FunctionName -> + TypeRepr ret -> + (forall r . OverrideSim p sym ext r args ret (RegValue sym ret)) -> + Override p sym ext args ret +mkOverride' nm tp f = + Override { overrideName = nm + , overrideHandler = runOverrideSim tp f + } + +-- | Create an override from a statically inferrable return type and definition using 'OverrideSim'. +mkOverride :: + KnownRepr TypeRepr ret => + FunctionName -> + (forall r . OverrideSim p sym ext r args ret (RegValue sym ret)) -> + Override p sym ext args ret +mkOverride nm = mkOverride' nm knownRepr + +-- | Return override arguments. +getOverrideArgs :: OverrideSim p sym ext rtp args ret (RegMap sym args) +getOverrideArgs = use (stateOverrideFrame.overrideRegMap) + +withSimContext :: StateT (SimContext p sym ext) IO a -> OverrideSim p sym ext rtp args ret a +withSimContext m = + do ctx <- use stateContext + (r,ctx') <- liftIO $ runStateT m ctx + stateContext .= ctx' + return r + +-- | Call a function with the given arguments. +callFnVal :: + (IsExprBuilder sym, IsSyntaxExtension ext) => + FnVal sym args ret {- ^ Function to call -} -> + RegMap sym args {- ^ Arguments to the function -} -> + OverrideSim p sym ext rtp a r (RegEntry sym ret) +callFnVal cl args = + Sim $ StateContT $ \c -> runReaderT $ do + sym <- view stateSymInterface + loc <- liftIO $ getCurrentProgramLoc sym + callFunction cl args (ReturnToOverride c) loc + +-- | Call a function with the given arguments. Provide the arguments as an +-- @Assignment@ instead of as a @RegMap@. +callFnVal' :: + (IsExprBuilder sym, IsSyntaxExtension ext) => + FnVal sym args ret {- ^ Function to call -} -> + Ctx.Assignment (RegValue' sym) args {- ^ Arguments to the function -} -> + OverrideSim p sym ext rtp a r (RegValue sym ret) +callFnVal' cl args = + do let FunctionHandleRepr tps _ = fnValType cl + let args' = Ctx.zipWith (\tp (RV x) -> RegEntry tp x) tps args + regValue <$> callFnVal cl (RegMap args') + +-- | Call a control flow graph from 'OverrideSim'. +-- +-- Note that this computes the postdominator information, so there is some +-- performance overhead in the call. +callCFG :: + IsSyntaxExtension ext => + CFG ext blocks init ret {- ^ Function to run -} -> + RegMap sym init {- ^ Arguments to the function -} -> + OverrideSim p sym ext rtp a r (RegEntry sym ret) +callCFG cfg = callBlock cfg (cfgEntryBlockID cfg) + +-- | Call a block of a control flow graph from 'OverrideSim'. +-- +-- Note that this computes the postdominator information, so there is some +-- performance overhead in the call. +callBlock :: + IsSyntaxExtension ext => + CFG ext blocks init ret {- ^ Function to run -} -> + BlockID blocks args {- ^ Block to run -} -> + RegMap sym args {- ^ Arguments to the block -} -> + OverrideSim p sym ext rtp a r (RegEntry sym ret) +callBlock cfg bid args = + Sim $ StateContT $ \c -> runReaderT $ + let f = mkBlockFrame cfg bid (postdomInfo cfg) args in + ReaderT $ return . CallState (ReturnToOverride c) (CrucibleCall bid f) + +-- | Call an override in a new call frame. +callOverride :: + FnHandle args ret -> + Override p sym ext args ret -> + RegMap sym args -> + OverrideSim p sym ext rtp a r (RegEntry sym ret) +callOverride h ovr args = + Sim $ StateContT $ \c -> runReaderT $ + let f = OverrideFrame (overrideName ovr) (SomeHandle h) args in + ReaderT $ return . CallState (ReturnToOverride c) (OverrideCall ovr f) + + +-- | Add a failed assertion. This aborts execution along the current +-- evaluation path, and adds a proof obligation ensuring that we can't get here +-- in the first place. +overrideError :: IsSymInterface sym => SimErrorReason -> OverrideSim p sym ext rtp args res a +overrideError err = Sim $ StateContT $ \_ -> runErrorHandler err + + +-- | Abort the current thread of execution for the given reason. Unlike @overrideError@, +-- this operation will not add proof obligation, even if the given abort reason +-- is due to an assertion failure. Use @overrideError@ instead if a proof obligation +-- should be generated. +overrideAbort :: AbortExecReason -> OverrideSim p sym ext rtp args res a +overrideAbort abt = Sim $ StateContT $ \_ -> runAbortHandler abt + +overrideReturn :: KnownRepr TypeRepr res => RegValue sym res -> OverrideSim p sym ext rtp args res a +overrideReturn v = Sim $ StateContT $ \_ -> runReaderT $ returnValue (RegEntry knownRepr v) + +overrideReturn' :: RegEntry sym res -> OverrideSim p sym ext rtp args res a +overrideReturn' v = Sim $ StateContT $ \_ -> runReaderT $ returnValue v + +-- | Perform a symbolic branch on the given predicate. If we can determine +-- that the predicate must be either true or false, we will exeucte only +-- the "then" or the "else" branch. Otherwise, both branches will be executed +-- and the results merged when a value is returned from the override. NOTE! +-- this means the code following this symbolic branch may be executed more than +-- once; in particular, side effects may happen more than once. +-- +-- In order to ensure that push/abort/mux bookeeping is done properly, all +-- symbolic values that will be used in the branches should be inserted into +-- the @RegMap@ argument of this function, and retrieved in the branches using +-- the @getOverrideArgs@ function. Otherwise mux errors may later occur, which +-- will be very confusing. In other words, don't directly use symbolic values +-- computed before calling this function; you must instead first put them into +-- the @RegMap@ and get them out again later. +symbolicBranch :: + IsSymInterface sym => + Pred sym {- ^ Predicate to branch on -} -> + + RegMap sym then_args {- ^ argument values for the then branch -} -> + OverrideSim p sym ext rtp then_args res a {- ^ then branch -} -> + Maybe Position {- ^ optional location for then branch -} -> + + RegMap sym else_args {- ^ argument values for the else branch -} -> + OverrideSim p sym ext rtp else_args res a {- ^ else branch -} -> + Maybe Position {- ^ optional location for else branch -} -> + + OverrideSim p sym ext rtp args res a +symbolicBranch p thn_args thn thn_pos els_args els els_pos = + Sim $ StateContT $ \c -> runReaderT $ + do old_args <- view (stateTree.actFrame.overrideTopFrame.overrideRegMap) + let thn' = ReaderT (runStateContT + (unSim thn) + (\x st -> c x (st & stateTree.actFrame.overrideTopFrame.overrideRegMap .~ old_args))) + let els' = ReaderT (runStateContT + (unSim els) + (\x st -> c x (st & stateTree.actFrame.overrideTopFrame.overrideRegMap .~ old_args))) + overrideSymbolicBranch p thn_args thn' thn_pos els_args els' els_pos + +-- | Perform a series of symbolic branches. This operation will evaluate a +-- series of branches, one for each element of the list. The semantics of +-- this construct is that the predicates are evaluated in order, until +-- the first one that evaluates true; this branch will be the taken branch. +-- In other words, this operates like a chain of if-then-else statements; +-- later branches assume that earlier branches were not taken. +-- +-- If no predicate is true, the construct will abort with a @VariantOptionsExhausted@ +-- reason. If you wish to report an error condition instead, you should add a +-- final default case with a true predicate that calls @overrideError@. +-- As with @symbolicBranch@, be aware that code following this operation may be +-- called several times, and side effects may occur more than once. +-- +-- As with @symbolicBranch@, any symbolic values needed by the branches should be +-- placed into the @RegMap@ argument and retrieved when needed. See the comment +-- on @symbolicBranch@. +symbolicBranches :: forall p sym ext rtp args new_args res a. + IsSymInterface sym => + RegMap sym new_args {- ^ argument values for the branches -} -> + [(Pred sym, OverrideSim p sym ext rtp (args <+> new_args) res a, Maybe Position)] + {- ^ Branches to consider -} -> + OverrideSim p sym ext rtp args res a +symbolicBranches new_args xs0 = + Sim $ StateContT $ \c -> runReaderT $ + do sym <- view stateSymInterface + top_loc <- liftIO $ getCurrentProgramLoc sym + old_args <- view (stateTree.actFrame.overrideTopFrame.overrideRegMap) + let all_args = appendRegs old_args new_args + let c' x st = c x (st & stateTree.actFrame.overrideTopFrame.overrideRegMap .~ old_args) + let go _ [] = ReaderT $ runAbortHandler (VariantOptionsExhausted top_loc) + go !i ((p,m,mpos):xs) = + let msg = T.pack ("after branch " ++ show i) + m' = ReaderT (runStateContT (unSim m) c') + in overrideSymbolicBranch p all_args m' mpos old_args (go (i+1) xs) (Just (OtherPos msg)) + go (0::Integer) xs0 + +-- | Non-deterministically choose among several feasible branches. +-- +-- Unlike 'symbolicBranches', this function does not take only the first branch +-- with a predicate that evaluates to true; instead it takes /all/ branches with +-- predicates that are not syntactically false (or cannot be proved unreachable +-- with path satisfiability checking, if enabled). Each branch will /not/ assume +-- that other branches weren't taken. +-- +-- As with 'symbolicBranch', any symbolic values needed by the branches should be +-- placed into the @RegMap@ argument and retrieved when needed. See the comment +-- on 'symbolicBranch'. +-- +-- Operationally, this works by by numbering all of the branches from 0 to n, +-- inventing a symbolic integer variable z, and adding z = i (where i ranges +-- from 0 to n) to the branch condition for each branch, and calling +-- 'symbolicBranches' on the result. Even though each branch given to +-- 'symbolicBranches' assumes earlier branches are not taken, each branch +-- condition has the form @(z = i) and p@, so the negation @~((z = i) and p)@ +-- is equivalent to @(z != i) or ~p@, so later branches don't assume the +-- negation of the branch condition of earlier branches (i.e., @~p@). +nondetBranches :: forall p sym ext rtp args new_args res a. + IsSymInterface sym => + RegMap sym new_args {- ^ argument values for the branches -} -> + [(Pred sym, OverrideSim p sym ext rtp (args <+> new_args) res a, Maybe Position)] + {- ^ Branches to consider -} -> + OverrideSim p sym ext rtp args res a +nondetBranches new_args xs0 = + do sym <- getSymInterface + z <- liftIO $ freshNat sym (safeSymbol "nondetBranchesZ") + xs <- for (zip [(0 :: Natural)..] xs0) $ \(i, (p, v, position)) -> + do p' <- liftIO $ andPred sym p =<< natEq sym z =<< natLit sym i + return (p', v, position) + symbolicBranches new_args xs + +-------------------------------------------------------------------------------- +-- FnBinding + +-- | A pair containing a handle and the state associated to execute it. +data FnBinding p sym ext where + FnBinding :: FnHandle args ret + -> FnState p sym ext args ret + -> FnBinding p sym ext + +-- | Add function binding to map. +insertFnBinding :: FunctionBindings p sym ext + -> FnBinding p sym ext + -> FunctionBindings p sym ext +insertFnBinding m (FnBinding h s) = FnBindings $ insertHandleMap h s $ fnBindings m + +-- | Build a map of function bindings from a list of +-- handle/binding pairs. +fnBindingsFromList :: [FnBinding p sym ext] -> FunctionBindings p sym ext +fnBindingsFromList = foldl' insertFnBinding $ FnBindings emptyHandleMap + +registerFnBinding :: FnBinding p sym ext + -> OverrideSim p sym ext rtp a r () +registerFnBinding (FnBinding h s) = bindFnHandle h s + +-------------------------------------------------------------------------------- +-- AnyFnBindings + +-- | This quantifies over function bindings that can work for any symbolic interface. +data AnyFnBindings ext = AnyFnBindings (forall p sym . IsSymInterface sym => [FnBinding p sym ext]) + +-------------------------------------------------------------------------------- +-- Intrinsic utility definitions + +type IntrinsicImpl p sym ext args ret = + IsSymInterface sym => FnHandle args ret -> Override p sym ext args ret + +useIntrinsic :: + FnHandle args ret -> + (FnHandle args ret -> Override p sym ext args ret) -> + FnBinding p sym ext +useIntrinsic hdl impl = FnBinding hdl (UseOverride (impl hdl)) + +-- | Make an IntrinsicImpl from an explicit implementation +mkIntrinsic :: forall p sym ext args ret. + Ctx.CurryAssignmentClass args => + (forall r. Proxy r + -> sym + -> Ctx.CurryAssignment args + (RegEntry sym) + (OverrideSim p sym ext r args ret (RegValue sym ret))) + {- ^ Override implementation, given a proxy value to fix the type, a + reference to the symbolic engine, and a curried arguments -} -> + FnHandle args ret -> + Override p sym ext args ret +mkIntrinsic m hdl = mkOverride' (handleName hdl) (handleReturnType hdl) ovr + where + ovr :: forall r. OverrideSim p sym ext r args ret (RegValue sym ret) + ovr = do + sym <- getSymInterface + (RegMap args) <- getOverrideArgs + Ctx.uncurryAssignment (m (Proxy :: Proxy r) sym) args + +-------------------------------------------------------------------------------- +-- Typed overrides + +-- | An action in 'OverrideSim', together with 'TypeRepr's for its arguments +-- and return values. This type is used across several frontends to define +-- overrides for built-in functions, e.g., @malloc@ in the LLVM frontend. +-- +-- For maximal reusability, frontends may define 'TypedOverride's that are +-- polymorphic in (any of) @p@, @sym@, and @ext@. +data TypedOverride p sym ext args ret + = TypedOverride + { typedOverrideHandler :: + forall rtp args' ret'. + Ctx.Assignment (RegValue' sym) args -> + OverrideSim p sym ext rtp args' ret' (RegValue sym ret) + , typedOverrideArgs :: CtxRepr args + , typedOverrideRet :: TypeRepr ret + } + +-- | A 'TypedOverride' with the type parameters @args@, @ret@ existentially +-- quantified +data SomeTypedOverride p sym ext = + forall args ret. SomeTypedOverride (TypedOverride p sym ext args ret) + +-- | Create an override from a 'TypedOverride'. +runTypedOverride :: + FunctionName -> + TypedOverride p sym ext args ret -> + Override p sym ext args ret +runTypedOverride nm typedOvr = mkOverride' nm (typedOverrideRet typedOvr) $ do + RegMap args <- getOverrideArgs + typedOverrideHandler typedOvr (fmapFC (RV . regValue) args) diff --git a/src/Lang/Crucible/Simulator/PathSatisfiability.hs b/src/Lang/Crucible/Simulator/PathSatisfiability.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/PathSatisfiability.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.PathSatisfiability +-- Description : Support for performing path satisfiability checks +-- at symbolic branch points +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.PathSatisfiability + ( checkPathSatisfiability + , pathSatisfiabilityFeature + , checkSatToConsiderBranch + , BranchResult(..) + ) where + +import Control.Lens( (^.) ) +import Control.Monad.Reader +import qualified Prettyprinter as PP + +import Lang.Crucible.Backend +import Lang.Crucible.Backend.Online (BranchResult(..)) +import Lang.Crucible.CFG.Core +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.Operations + +import What4.Concrete +import What4.Config +import What4.Interface +import What4.ProgramLoc +import What4.SatResult + +checkPathSatisfiability :: ConfigOption BaseBoolType +checkPathSatisfiability = configOption knownRepr "checkPathSat" + +pathSatOptions :: [ConfigDesc] +pathSatOptions = + [ mkOpt + checkPathSatisfiability + boolOptSty + (Just (PP.pretty "Perform path satisfiability checks at symbolic branches")) + (Just (ConcreteBool True)) + ] + + +pathSatisfiabilityFeature :: forall sym. + IsSymInterface sym => + sym -> + (Maybe ProgramLoc -> Pred sym -> IO BranchResult) + {- ^ An action for considering the satisfiability of a predicate. + In the current state of the symbolic interface, indicate what + we can determine about the given predicate. -} -> + IO (GenericExecutionFeature sym) +pathSatisfiabilityFeature sym considerSatisfiability = + do tryExtendConfig pathSatOptions (getConfiguration sym) + pathSatOpt <- liftIO $ getOptionSetting checkPathSatisfiability (getConfiguration sym) + return $ GenericExecutionFeature $ onStep pathSatOpt + + where + onStep :: + OptionSetting BaseBoolType -> + ExecState p sym ext rtp -> + IO (ExecutionFeatureResult p sym ext rtp) + + onStep pathSatOpt (SymbolicBranchState p tp fp _tgt st) = + getOpt pathSatOpt >>= \case + False -> return ExecutionFeatureNoChange + True -> + do loc <- getCurrentProgramLoc sym + considerSatisfiability ploc p >>= \case + IndeterminateBranchResult -> + return ExecutionFeatureNoChange + NoBranch chosen_branch -> withBackend (st ^. stateContext) $ \bak -> + do p' <- if chosen_branch then return p else notPred sym p + let frm = if chosen_branch then tp else fp + addAssumption bak (BranchCondition loc (pausedLoc frm) p') + ExecutionFeatureNewState <$> runReaderT (resumeFrame frm (asContFrame (st^.stateTree))) st + UnsatisfiableContext -> + return (ExecutionFeatureNewState (AbortState (InfeasibleBranch loc) st)) + where + ploc = st ^. stateLocation + + onStep _ _ = return ExecutionFeatureNoChange + + +checkSatToConsiderBranch :: + IsSymInterface sym => + sym -> + (Pred sym -> IO (SatResult () ())) -> + (Pred sym -> IO BranchResult) +checkSatToConsiderBranch sym checkSat p = + do pnot <- notPred sym p + p_res <- checkSat p + pnot_res <- checkSat pnot + case (p_res, pnot_res) of + (Unsat{}, Unsat{}) -> return UnsatisfiableContext + (_ , Unsat{}) -> return (NoBranch True) + (Unsat{}, _ ) -> return (NoBranch False) + _ -> return IndeterminateBranchResult diff --git a/src/Lang/Crucible/Simulator/PathSplitting.hs b/src/Lang/Crucible/Simulator/PathSplitting.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/PathSplitting.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.PathSplitting +-- Description : Support for implementing path splitting +-- Copyright : (c) Galois, Inc 2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module provides an execution feature that converts symbolic +-- branches into path splitting by pushing unexplored paths onto a +-- worklist instead of performing eager path merging (the default +-- behavior). +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.PathSplitting + ( WorkItem(..) + , WorkList + , queueWorkItem + , dequeueWorkItem + , restoreWorkItem + , pathSplittingFeature + , executeCrucibleDFSPaths + ) where + +import Control.Lens ( (^.) ) +import Control.Monad.Reader +import Data.IORef +import Data.Sequence( Seq ) +import qualified Data.Sequence as Seq +import Data.Word + +import What4.Interface +import What4.ProgramLoc + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Extension +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.Operations + + +-- | A `WorkItem` represents a suspended symbolic execution path that +-- can later be resumed. It captures all the relevant context that +-- is required to recreate the simulator state at the point when +-- the path was suspended. +data WorkItem p sym ext rtp = + forall f args. + WorkItem + { -- | The predicate we branched on to generate this work item + workItemPred :: Pred sym + -- | The location of the symbolic branch + , workItemLoc :: ProgramLoc + -- | The paused execution frame + , workItemFrame :: PausedFrame p sym ext rtp f + -- | The overall execution state of this path + , workItemState :: SimState p sym ext rtp f ('Just args) + -- | The assumption state of the symbolic backend when we suspended this work item + , workItemAssumes :: AssumptionState sym + } + +-- | A `WorkList` represents a sequence of `WorkItems` that still +-- need to be explored. +type WorkList p sym ext rtp = IORef (Seq (WorkItem p sym ext rtp)) + +-- | Put a work item onto the front of the work list. +queueWorkItem :: WorkItem p sym ext rtp -> WorkList p sym ext rtp -> IO () +queueWorkItem i wl = atomicModifyIORef' wl (\xs -> (i Seq.<| xs, ())) + +-- | Pull a work item off the front of the work list, if there are any left. +-- When used with `queueWorkItem`, this function uses the work list as a stack +-- and will explore paths in a depth-first manner. +dequeueWorkItem :: WorkList p sym ext rtp -> IO (Maybe (WorkItem p sym ext rtp)) +dequeueWorkItem wl = + atomicModifyIORef' wl $ \xs -> + case Seq.viewl xs of + Seq.EmptyL -> (xs, Nothing) + i Seq.:< xs' -> (xs', Just i) + +-- | Given a work item, restore the simulator state so that it is ready to resume +-- exploring the path that it represents. +restoreWorkItem :: + IsSymInterface sym => + WorkItem p sym ext rtp -> + IO (ExecState p sym ext rtp) +restoreWorkItem (WorkItem branchPred loc frm st assumes) = + do let sym = st ^. stateSymInterface + let simCtx = st ^. stateContext + withBackend simCtx $ \bak -> + do setCurrentProgramLoc sym loc + restoreAssumptionState bak assumes + addAssumption bak (BranchCondition loc (pausedLoc frm) branchPred) + let ctx = st ^. stateTree . actContext + runReaderT (resumeFrame frm ctx) st + +-- | The path splitting execution feature always selects the \"true\" branch +-- of a symbolic branch to explore first, and pushes the \"false\" branch +-- onto the front of the given work list. With this feature enabled, +-- a single path will be explored with no symbolic branching until it is finished, +-- and all remaining unexplored paths will be suspended in the work list, where +-- they can be later resumed. +pathSplittingFeature :: + IsSymInterface sym => + WorkList p sym ext rtp -> + ExecutionFeature p sym ext rtp +pathSplittingFeature wl = ExecutionFeature $ \case + SymbolicBranchState p trueFrame falseFrame _bt st -> + withBackend (st^.stateContext) $ \bak -> + do let sym = st ^. stateSymInterface + pnot <- notPred sym p + assumes <- saveAssumptionState bak + loc <- getCurrentProgramLoc sym + + let wi = WorkItem + { workItemPred = pnot + , workItemLoc = loc + , workItemFrame = forgetPostdomFrame falseFrame + , workItemState = st + , workItemAssumes = assumes + } + queueWorkItem wi wl + + addAssumption bak (BranchCondition loc (pausedLoc trueFrame) p) + + let ctx = st ^. stateTree . actContext + ExecutionFeatureNewState <$> runReaderT (resumeFrame (forgetPostdomFrame trueFrame) ctx) st + + _ -> return ExecutionFeatureNoChange + + +-- | This function executes a state using the path splitting execution +-- feature. Each time a path is completed, the given result +-- continuation is executed on it. If the continuation returns +-- 'True', additional paths will be executed; otherwise, we exit early +-- and exploration stops. +-- +-- If exploration continues, the next work item will be +-- popped of the front of the work list and will be executed in turn. +-- If a timeout result is encountered, we instead stop executing paths early. +-- The return value of this function is the number of paths that were +-- completed, and a list of remaining paths (if any) that were not +-- explored due to timeout or early exit. +executeCrucibleDFSPaths :: forall p sym ext rtp. + ( IsSymInterface sym + , IsSyntaxExtension ext + ) => + [ ExecutionFeature p sym ext rtp ] {- ^ Execution features to install -} -> + ExecState p sym ext rtp {- ^ Execution state to begin executing -} -> + (ExecResult p sym ext rtp -> IO Bool) + {- ^ Path result continuation, return 'True' to explore more paths -} -> + IO (Word64, Seq (WorkItem p sym ext rtp)) +executeCrucibleDFSPaths execFeatures exst0 cont = + do wl <- newIORef Seq.empty + cnt <- newIORef (1::Word64) + let feats = execFeatures ++ [pathSplittingFeature wl] + go wl cnt feats exst0 + + where + go wl cnt feats exst = + do res <- executeCrucible feats exst + goOn <- cont res + case res of + TimeoutResult _ -> + do xs <- readIORef wl + i <- readIORef cnt + return (i,xs) + + _ | not goOn -> + do xs <- readIORef wl + i <- readIORef cnt + return (i,xs) + + | otherwise -> + dequeueWorkItem wl >>= \case + Nothing -> + do i <- readIORef cnt + return (i, mempty) + + Just wi -> + do modifyIORef' cnt succ + restoreWorkItem wi >>= go wl cnt feats diff --git a/src/Lang/Crucible/Simulator/PositionTracking.hs b/src/Lang/Crucible/Simulator/PositionTracking.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/PositionTracking.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.PositionTracking +-- Description : Execution feature for tracking program positions +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.PositionTracking + ( positionTrackingFeature + ) where + +import Control.Lens ((^.), to) +import Control.Monad.IO.Class + +import Lang.Crucible.Backend +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.ExecutionTree + + +-- | This execution feature adds a @LocationReachedEvent@ to +-- the backend assumption tracking whenever execution reaches the +-- head of a basic block. +positionTrackingFeature :: + IsSymInterface sym => + sym -> + IO (GenericExecutionFeature sym) +positionTrackingFeature _sym = return $ GenericExecutionFeature onStep + where + onStep :: + ExecState p sym ext rtp -> + IO (ExecutionFeatureResult p sym ext rtp) + onStep exst@(RunningState (RunBlockStart _bid) st) = + do let loc = st ^. (stateCrucibleFrame.to frameProgramLoc) + let simCtx = st ^. stateContext + liftIO $ withBackend simCtx $ \bak -> + addAssumptions bak (singleEvent (LocationReachedEvent loc)) + return (ExecutionFeatureModifiedState exst) + + onStep _ = return ExecutionFeatureNoChange diff --git a/src/Lang/Crucible/Simulator/Profiling.hs b/src/Lang/Crucible/Simulator/Profiling.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/Profiling.hs @@ -0,0 +1,554 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.Profiling +-- Description : Profiling support for the simulator +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.Profiling + ( profilingFeature + , ProfilingOptions(..) + , EventFilter(..) + , profilingEventFilter + , newProfilingTable + , recordSolverEvent + , startRecordingSolverEvents + , enterEvent + , exitEvent + , inProfilingFrame + , readMetrics + , CrucibleProfile(..) + , readProfilingState + , writeProfileReport + + -- * Profiling data structures + , CGEvent(..) + , CGEventType(..) + , ProfilingTable(..) + , Lang.Crucible.Simulator.ExecutionTree.Metric(..) + , Metrics(..) + , symProUIJSON + , symProUIString + ) where + +import qualified Control.Exception as Ex +import Control.Lens +import Control.Monad ((<=<), when) +import Data.Foldable (toList) +import Data.Hashable +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Parameterized.TraversableF +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.Format +import System.IO (withFile, IOMode(..), hPutStrLn) +import Text.JSON +import GHC.Generics (Generic) + + +import What4.FunctionName +import What4.Interface +import What4.ProgramLoc +import What4.SatResult + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Core +import Lang.Crucible.Simulator.CallFrame +import Lang.Crucible.Simulator.EvalStmt +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.Operations + + +data Metrics f = + Metrics + { metricSplits :: f Integer + , metricMerges :: f Integer + , metricAborts :: f Integer + , metricSolverStats :: f Statistics + , metricExtraMetrics :: f (Map Text Integer) + } + +deriving instance Show (Metrics Identity) +deriving instance Generic (Metrics Identity) + +traverseF_metrics :: Applicative m => + (forall s. e s -> m (f s)) -> + Metrics e -> m (Metrics f) +traverseF_metrics h (Metrics x1 x2 x3 x4 x5) = + Metrics <$> h x1 <*> h x2 <*> h x3 <*> h x4 <*> h x5 + +instance FunctorF Metrics where + fmapF = fmapFDefault +instance FoldableF Metrics where + foldMapF = foldMapFDefault +instance TraversableF Metrics where + traverseF = traverseF_metrics + +metricsToJSON :: Metrics Identity -> UTCTime -> JSValue +metricsToJSON m time = JSObject $ toJSObject $ + [ ("time", utcTimeToJSON time) + , ("allocs", showJSON $ statAllocs $ solverStats ) + , ("paths", showJSON $ runIdentity $ metricSplits m ) + , ("merge-count", showJSON $ runIdentity $ metricMerges m ) + , ("abort-count", showJSON $ runIdentity $ metricAborts m ) + , ("non-linear-count", showJSON $ statNonLinearOps $ solverStats ) + ] ++ [ (Text.unpack k, showJSON v) + | (k, v) <- Map.toList $ runIdentity $ metricExtraMetrics m ] + where + solverStats = runIdentity $ metricSolverStats m + + +data CGEventType = ENTER | EXIT | BLOCK | BRANCH + deriving (Show,Eq,Ord,Generic) + +data CGEvent = + CGEvent + { cgEvent_fnName :: FunctionName + , cgEvent_source :: Maybe Position + , cgEvent_callsite :: Maybe Position + , cgEvent_type :: CGEventType + , cgEvent_blocks :: [String] + , cgEvent_metrics :: Metrics Identity + , cgEvent_time :: UTCTime + , cgEvent_id :: Integer + } + deriving (Show, Generic) + +-- FIXME... figure out why the UI seems to want this in milliseconds... +utcTimeToJSON :: UTCTime -> JSValue +utcTimeToJSON t = + showJSON (1e3 * (fromRational $ toRational $ utcTimeToPOSIXSeconds t) :: Double) + +cgEventTypeToJSON :: CGEventType -> JSValue +cgEventTypeToJSON ENTER = showJSON "ENTER" +cgEventTypeToJSON EXIT = showJSON "EXIT" +cgEventTypeToJSON BLOCK = showJSON "BLOCK" +cgEventTypeToJSON BRANCH = showJSON "BRANCH" + +cgEventToJSON :: CGEvent -> JSValue +cgEventToJSON ev = JSObject $ toJSObject $ + [ ("function", showJSON $ functionName $ cgEvent_fnName ev) + , ("type", cgEventTypeToJSON (cgEvent_type ev)) + , ("metrics", metricsToJSON (cgEvent_metrics ev) (cgEvent_time ev)) + ] + ++ + (case cgEvent_source ev of + Nothing -> [] + Just p -> [("source", positionToJSON p)]) + ++ + (case cgEvent_callsite ev of + Nothing -> [] + Just p -> [("callsite", positionToJSON p)]) + ++ + (case cgEvent_blocks ev of + [] -> [] + xs -> [("blocks", showJSON xs)]) + +positionToJSON :: Position -> JSValue +positionToJSON p = showJSON $ show $ p + +solverEventToJSON :: (UTCTime, SolverEvent) -> JSValue +solverEventToJSON (time, ev) = + case ev of + SolverStartSATQuery ssq -> startSATQueryToJSON time ssq + SolverEndSATQuery esq -> endSATQueryToJSON time esq + +startSATQueryToJSON :: UTCTime -> SolverStartSATQuery -> JSValue +startSATQueryToJSON time ssq = JSObject $ toJSObject + [ ("type", showJSON "start") + , ("time", utcTimeToJSON time) + , ("part", showJSON "solver") + , ("solver", showJSON $ satQuerySolverName ssq) + , ("description", showJSON $ satQueryReason ssq) + ] + +endSATQueryToJSON :: UTCTime -> SolverEndSATQuery -> JSValue +endSATQueryToJSON time esq = JSObject $ toJSObject $ + [ ("type", showJSON "finish") + , ("time", utcTimeToJSON time) + ] ++ + case (satQueryResult esq) of + Sat{} -> [("sat", showJSON True)] + Unsat{} -> [("sat", showJSON False)] + Unknown{} -> [] + + +callGraphJSON :: UTCTime -> Metrics Identity -> Seq CGEvent -> JSValue +callGraphJSON now m evs = JSObject $ toJSObject + [ ("type", showJSON "callgraph") + , ("events", JSArray allEvs) + ] + + where + allEvs = map cgEventToJSON (toList evs ++ closingEvents now m evs) + + +symProUIString :: String -> String -> ProfilingTable -> IO String +symProUIString nm source tbl = + do js <- symProUIJSON nm source tbl + return ("data.receiveData("++ encode js ++ ");") + + +symProUIJSON :: String -> String -> ProfilingTable -> IO JSValue +symProUIJSON nm source tbl = + do now <- getCurrentTime + m <- readMetrics tbl + evs <- readIORef (callGraphEvents tbl) + solverEvs <- readIORef (solverEvents tbl) + return $ JSArray $ + [ JSObject $ toJSObject $ metadata now + , callGraphJSON now m evs + , JSObject $ toJSObject $ solver_calls solverEvs + ] + where + solver_calls evs = + [ ("type", showJSON "solver-calls") + , ("events", JSArray $ map solverEventToJSON $ toList evs) + ] + + metadata now = + [ ("type", showJSON "metadata") + , ("form", showJSON "") + , ("name", showJSON nm) + , ("source", showJSON source) + , ("time", showJSON $ formatTime defaultTimeLocale rfc822DateFormat now) + , ("version", showJSON "1") + ] + +data ProfilingTable = + ProfilingTable + { callGraphEvents :: IORef (Seq CGEvent) + , eventDedups :: IORef (HashSet EventDedup) + , metrics :: Metrics IORef + , eventIDRef :: IORef Integer + , solverEvents :: IORef (Seq (UTCTime, SolverEvent)) + } + +data EventFilter = + EventFilter + { recordProfiling :: Bool + , recordCoverage :: Bool + } + +-- | An `EventFilter` that enables only Crucible profiling. +profilingEventFilter :: EventFilter +profilingEventFilter = EventFilter + { recordProfiling = True + , recordCoverage = False + } + +data CrucibleProfile = + CrucibleProfile + { crucibleProfileTime :: UTCTime + , crucibleProfileCGEvents :: [CGEvent] + , crucibleProfileSolverEvents :: [SolverEvent] + } deriving (Show, Generic) + +data EventDedup = + BlockDedup FunctionName String + | BranchDedup FunctionName [String] + deriving (Eq, Generic) + +instance Hashable EventDedup + +readProfilingState :: ProfilingTable -> IO (UTCTime, [CGEvent], [(UTCTime, SolverEvent)]) +readProfilingState tbl = + do now <- getCurrentTime + m <- readMetrics tbl + cgevs <- readIORef (callGraphEvents tbl) + sevs <- readIORef (solverEvents tbl) + return (now, toList cgevs ++ closingEvents now m cgevs, toList sevs) + +openEventFrames :: Seq CGEvent -> [CGEvent] +openEventFrames = go [] + where + go :: [CGEvent] -> Seq CGEvent -> [CGEvent] + go xs Seq.Empty = xs + go xs (e Seq.:<| es) = + case cgEvent_type e of + ENTER -> go (e:xs) es + EXIT -> go (tail xs) es + _ -> go xs es + +openToCloseEvent :: UTCTime -> Metrics Identity -> CGEvent -> CGEvent +openToCloseEvent now m cge = + cge + { cgEvent_type = EXIT + , cgEvent_metrics = m + , cgEvent_time = now + } + +closingEvents :: UTCTime -> Metrics Identity -> Seq CGEvent -> [CGEvent] +closingEvents now m = map (openToCloseEvent now m) . openEventFrames + +newProfilingTable :: IO ProfilingTable +newProfilingTable = + do m <- Metrics <$> newIORef 0 + <*> newIORef 0 + <*> newIORef 0 + <*> newIORef zeroStatistics + <*> newIORef Map.empty + -- TODO: Find the actual custom metrics and + -- initialize them to zero. Needs a change in + -- the Crux API; currently 'newProfilingTable' + -- is called before the custom metrics are set + -- up. For now, the extra metrics are missing + -- from the very earliest events in the log; + -- the JS front end works around this by + -- assuming that any missing value is a zero. + evs <- newIORef mempty + dedups <- newIORef mempty + idref <- newIORef 0 + solverevs <- newIORef mempty + let tbl = ProfilingTable evs dedups m idref solverevs + return tbl + +recordSolverEvent :: ProfilingTable -> SolverEvent -> IO () +recordSolverEvent tbl ev = do + do now <- getCurrentTime + xs <- readIORef (solverEvents tbl) + writeIORef (solverEvents tbl) (xs Seq.|> (now,ev)) + +startRecordingSolverEvents :: + IsSymInterface sym => + sym -> + ProfilingTable -> + IO () +startRecordingSolverEvents sym tbl = + setSolverLogListener sym (Just (recordSolverEvent tbl)) + +nextEventID :: ProfilingTable -> IO Integer +nextEventID tbl = + do i <- readIORef (eventIDRef tbl) + writeIORef (eventIDRef tbl) $! (i+1) + return i + +dedupEvent :: ProfilingTable -> EventDedup -> IO () -> IO () +dedupEvent tbl evt f = + do seen <- readIORef (eventDedups tbl) + when (not $ HashSet.member evt seen) $ + do writeIORef (eventDedups tbl) (HashSet.insert evt seen) + f + +inProfilingFrame :: + ProfilingTable -> + FunctionName -> + Maybe ProgramLoc -> + IO a -> + IO a +inProfilingFrame tbl nm mloc action = + Ex.bracket_ + (enterEvent tbl nm mloc) + (exitEvent tbl nm) + action + +enterEvent :: + ProfilingTable -> + FunctionName -> + Maybe ProgramLoc -> + IO () +enterEvent tbl nm callLoc = + do now <- getCurrentTime + m <- readMetrics tbl + i <- nextEventID tbl + let p = fmap plSourceLoc callLoc + modifyIORef' (callGraphEvents tbl) (Seq.|> CGEvent nm Nothing p ENTER [] m now i) + +readMetrics :: ProfilingTable -> IO (Metrics Identity) +readMetrics tbl = traverseF (pure . Identity <=< readIORef) (metrics tbl) + +exitEvent :: + ProfilingTable -> + FunctionName -> + IO () +exitEvent tbl nm = + do now <- getCurrentTime + m <- traverseF (pure . Identity <=< readIORef) (metrics tbl) + i <- nextEventID tbl + modifyIORef' (callGraphEvents tbl) (Seq.|> CGEvent nm Nothing Nothing EXIT [] m now i) + +blockEvent :: + ProfilingTable -> + FunctionName -> + Maybe ProgramLoc -> + Some (BlockID blocks) -> + IO () +blockEvent tbl nm callLoc blk = + dedupEvent tbl (BlockDedup nm (show blk)) $ + do now <- getCurrentTime + m <- readMetrics tbl + i <- nextEventID tbl + let p = fmap plSourceLoc callLoc + modifyIORef' (callGraphEvents tbl) + (Seq.|> CGEvent nm Nothing p BLOCK [show blk] m now i) + +branchEvent :: + ProfilingTable -> + FunctionName -> + Maybe ProgramLoc -> + [Some (BlockID blocks)] -> + IO () +branchEvent tbl nm callLoc blks = + dedupEvent tbl (BranchDedup nm (map show blks)) $ + do now <- getCurrentTime + m <- readMetrics tbl + i <- nextEventID tbl + let p = fmap plSourceLoc callLoc + modifyIORef' (callGraphEvents tbl) + (Seq.|> CGEvent nm Nothing p BRANCH (map show blks) m now i) + + +updateProfilingTable :: + IsExprBuilder sym => + ProfilingTable -> + EventFilter -> + ExecState p sym ext rtp -> + IO () +updateProfilingTable tbl filt exst = do + when (recordProfiling filt) $ do + let sym = execStateContext exst ^. ctxSymInterface + stats <- getStatistics sym + writeIORef (metricSolverStats (metrics tbl)) stats + + case execStateSimState exst of + Just (SomeSimState simst) -> do + let extraMetrics = execStateContext exst ^. profilingMetrics + extraMetricValues <- traverse (\m -> runMetric m simst) extraMetrics + writeIORef (metricExtraMetrics (metrics tbl)) extraMetricValues + Nothing -> + -- We can't poll custom metrics at the VERY beginning or end of + -- execution because 'ResultState' and 'InitialState' have no + -- 'SimState' values. This is probably fine---we still get to + -- poll them before and after the top-level function being + -- simulated, since it gets a 'CallState' and 'ReturnState' like + -- any other function. + return () + + case exst of + InitialState _ _ _ _ _ -> + enterEvent tbl startFunctionName Nothing + CallState _rh call st -> + enterEvent tbl (resolvedCallName call) (st^.stateLocation) + ReturnState nm _ _ _ -> + exitEvent tbl nm + TailCallState _ call st -> + do exitEvent tbl (st^.stateTree.actFrame.gpValue.frameFunctionName) + enterEvent tbl (resolvedCallName call) (st^.stateLocation) + SymbolicBranchState{} -> + modifyIORef' (metricSplits (metrics tbl)) succ + AbortState{} -> + modifyIORef' (metricAborts (metrics tbl)) succ + UnwindCallState _ _ st -> + exitEvent tbl (st^.stateTree.actFrame.gpValue.frameFunctionName) + BranchMergeState tgt st -> + when (isMergeState tgt st) + (modifyIORef' (metricMerges (metrics tbl)) succ) + _ -> return () + + when (recordCoverage filt) $ + case exst of + ControlTransferState res st -> + let funcName = st^.stateTree.actFrame.gpValue.frameFunctionName in + case res of + ContinueResumption (ResolvedJump blk _) -> + blockEvent tbl funcName (st^.stateLocation) (Some blk) + CheckMergeResumption (ResolvedJump blk _) -> + blockEvent tbl funcName (st^.stateLocation) (Some blk) + _ -> return () + RunningState (RunBlockEnd _) st -> + let funcName = st^.stateTree.actFrame.gpValue.frameFunctionName in + case st^.stateTree.actFrame.gpValue.crucibleSimFrame.frameStmts of + TermStmt loc term + | Just blocks <- termStmtNextBlocks term, + length blocks >= 2 -> + branchEvent tbl funcName (Just loc) blocks + _ -> return () + _ -> return () + +isMergeState :: + CrucibleBranchTarget f args -> + SimState p sym ext root f args -> + Bool +isMergeState tgt st = + case st^.stateTree.actContext of + VFFBranch _ctx _assume_frame _loc _p other_branch tgt' + | Just Refl <- testEquality tgt tgt' -> + case other_branch of + VFFActivePath{} -> False + VFFCompletePath{} -> True + VFFPartial _ctx _loc _p _ar NeedsToBeAborted -> True + _ -> False + + +data ProfilingOptions = + ProfilingOptions + { periodicProfileInterval :: NominalDiffTime + , periodicProfileAction :: ProfilingTable -> IO () + } + + +-- | Write a profiling report file in the JS/JSON format expected by tye symProUI front end. +writeProfileReport :: + FilePath {- ^ File to write -} -> + String {- ^ "name" for the report -} -> + String {- ^ "source" for the report -} -> + ProfilingTable {- ^ profiling data to populate the report -} -> + IO () +writeProfileReport fp name source tbl = + withFile fp WriteMode $ \h -> hPutStrLn h =<< symProUIString name source tbl + +-- | This feature will pay attention to function call entry/exit events +-- and track the elapsed time and various other metrics in the given +-- profiling table. The @ProfilingOptions@ can be used to export +-- intermediate profiling data at regular intervals, if desired. +profilingFeature :: + ProfilingTable -> + EventFilter -> + Maybe ProfilingOptions -> + IO (GenericExecutionFeature sym) + +profilingFeature tbl filt Nothing = + return $ GenericExecutionFeature $ \exst -> updateProfilingTable tbl filt exst >> return ExecutionFeatureNoChange + +profilingFeature tbl filt (Just profOpts) = + do startTime <- getCurrentTime + stateRef <- newIORef (computeNextState startTime) + return (feat stateRef) + + where + feat stateRef = GenericExecutionFeature $ \exst -> + do updateProfilingTable tbl filt exst + deadline <- readIORef stateRef + now <- getCurrentTime + if deadline >= now then + return ExecutionFeatureNoChange + else + do periodicProfileAction profOpts tbl + writeIORef stateRef (computeNextState now) + return ExecutionFeatureNoChange + + computeNextState :: UTCTime -> UTCTime + computeNextState lastOutputTime = addUTCTime (periodicProfileInterval profOpts) lastOutputTime diff --git a/src/Lang/Crucible/Simulator/RegMap.hs b/src/Lang/Crucible/Simulator/RegMap.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/RegMap.hs @@ -0,0 +1,329 @@ +---------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.RegMap +-- Description : Runtime representation of CFG registers +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- Register maps hold the values of registers at simulation/run time. +------------------------------------------------------------------------ +{-# LANGUAGE AllowAmbiguousTypes #-} -- for @reg@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Lang.Crucible.Simulator.RegMap + ( RegEntry(..) + , muxRegEntry + , RegMap(..) + , regMapSize + , emptyRegMap + , reg + , regVal + , regVal' + , assignReg + , assignReg' + , appendRegs + , takeRegs + , unconsReg + , muxRegForType + , muxReference + , eqReference + , pushBranchForType + , abortBranchForType + , pushBranchRegs + , abortBranchRegs + , pushBranchRegEntry + , abortBranchRegEntry + , mergeRegs + , asSymExpr + , module Lang.Crucible.Simulator.RegValue + ) where + + +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.TraversableFC + +import What4.Interface +import What4.WordMap + +import Lang.Crucible.CFG.Core (Reg(..)) +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegValue +import Lang.Crucible.Types +import Lang.Crucible.Utils.MuxTree +import Lang.Crucible.Backend +import Lang.Crucible.Panic + +------------------------------------------------------------------------ +-- RegMap + +-- | The value of a register. +data RegEntry sym tp = RegEntry { regType :: !(TypeRepr tp) + , regValue :: !(RegValue sym tp) + } + +-- | A set of registers in an execution frame. +newtype RegMap sym (ctx :: Ctx CrucibleType) + = RegMap { regMap :: Ctx.Assignment (RegEntry sym) ctx } + +regMapSize :: RegMap sym ctx -> Ctx.Size ctx +regMapSize (RegMap s) = Ctx.size s + +-- | Create a new set of registers. +emptyRegMap :: RegMap sym EmptyCtx +emptyRegMap = RegMap Ctx.empty + +assignReg :: TypeRepr tp + -> RegValue sym tp + -> RegMap sym ctx + -> RegMap sym (ctx ::> tp) +assignReg tp v (RegMap m) = RegMap (m Ctx.:> RegEntry tp v) +{-# INLINE assignReg #-} + +assignReg' :: RegEntry sym tp + -> RegMap sym ctx + -> RegMap sym (ctx ::> tp) +assignReg' v (RegMap m) = RegMap (m Ctx.:> v) +{-# INLINE assignReg' #-} + + +appendRegs :: + RegMap sym ctx -> + RegMap sym ctx' -> + RegMap sym (ctx <+> ctx') +appendRegs (RegMap m1) (RegMap m2) = RegMap (m1 Ctx.<++> m2) + +unconsReg :: + RegMap sym (ctx ::> tp) -> + (RegMap sym ctx, RegEntry sym tp) +unconsReg (RegMap (hd Ctx.:> tl)) = (RegMap hd, tl) + +takeRegs :: + Ctx.Size ctx -> + Ctx.Size ctx' -> + RegMap sym (ctx <+> ctx') -> + RegMap sym ctx +takeRegs sz sz' (RegMap m) = RegMap (Ctx.take sz sz' m) + +reg :: forall n sym ctx tp. Ctx.Idx n ctx tp => RegMap sym ctx -> RegValue sym tp +reg m = regVal m (Reg (Ctx.natIndex @n)) + +regVal :: RegMap sym ctx + -> Reg ctx tp + -> RegValue sym tp +regVal (RegMap a) r = v + where RegEntry _ v = a Ctx.! regIndex r + +regVal' :: RegMap sym ctx + -> Reg ctx tp + -> RegEntry sym tp +regVal' (RegMap a) r = a Ctx.! regIndex r + + +muxAny :: IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> ValMuxFn sym AnyType +muxAny s itefns p (AnyValue tpx x) (AnyValue tpy y) + | Just Refl <- testEquality tpx tpy = + AnyValue tpx <$> muxRegForType s itefns tpx p x y + | otherwise = throwUnsupported s $ unwords + ["Attempted to mux ANY values of different runtime type" + , show tpx, show tpy + ] + +muxReference :: + IsSymInterface sym => sym -> ValMuxFn sym (ReferenceType tp) +muxReference s = mergeMuxTree s + +eqReference :: + IsSymInterface sym => + sym -> + RegValue sym (ReferenceType tp) -> + RegValue sym (ReferenceType tp) -> + IO (Pred sym) +eqReference sym = muxTreeEq sym + + +{-# INLINABLE pushBranchForType #-} +pushBranchForType :: forall sym tp + . IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> TypeRepr tp + -> RegValue sym tp + -> IO (RegValue sym tp) +pushBranchForType s iTypes p = + case p of + IntrinsicRepr nm ctx -> + case MapF.lookup nm iTypes of + Just IntrinsicMuxFn -> pushBranchIntrinsic s iTypes nm ctx + Nothing -> \_ -> + panic "RegMap.pushBranchForType" + [ "Unknown intrinsic type:" + , "*** Name: " ++ show nm + ] + + AnyRepr -> \(AnyValue tpr x) -> AnyValue tpr <$> pushBranchForType s iTypes tpr x + + -- All remaining types do no push branch bookkeeping + _ -> return + +{-# INLINABLE abortBranchForType #-} +abortBranchForType :: forall sym tp + . IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> TypeRepr tp + -> RegValue sym tp + -> IO (RegValue sym tp) +abortBranchForType s iTypes p = + case p of + IntrinsicRepr nm ctx -> + case MapF.lookup nm iTypes of + Just IntrinsicMuxFn -> abortBranchIntrinsic s iTypes nm ctx + Nothing -> + panic "RegMap.abortBranchForType" + [ "Unknown intrinsic type:" + , "*** Name: " ++ show nm + ] + AnyRepr -> \(AnyValue tpr x) -> + AnyValue tpr <$> abortBranchForType s iTypes tpr x + + -- All remaining types do no abort branch bookkeeping + _ -> return + +{-# INLINABLE muxRegForType #-} +muxRegForType :: forall sym tp + . IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> TypeRepr tp + -> ValMuxFn sym tp +muxRegForType s itefns p = + case p of + UnitRepr -> muxReg s p + NatRepr -> muxReg s p + IntegerRepr -> muxReg s p + RealValRepr -> muxReg s p + FloatRepr _ -> muxReg s p + ComplexRealRepr -> muxReg s p + CharRepr -> muxReg s p + BoolRepr -> muxReg s p + StringRepr _ -> muxReg s p + IEEEFloatRepr _p -> muxReg s p + + AnyRepr -> muxAny s itefns + StructRepr ctx -> muxStruct (muxRegForType s itefns) ctx + VariantRepr ctx -> muxVariant s (muxRegForType s itefns) ctx + ReferenceRepr _x -> muxReference s + WordMapRepr w tp -> muxWordMap s w tp + BVRepr w -> + case isPosNat w of + Nothing -> \_ x _ -> return x + Just LeqProof -> bvIte s + FunctionHandleRepr _ _ -> muxReg s p + + MaybeRepr r -> mergePartExpr s (muxRegForType s itefns r) + VectorRepr r -> muxVector s (muxRegForType s itefns r) + SequenceRepr _r -> muxSymSequence s + StringMapRepr r -> muxStringMap s (muxRegForType s itefns r) + SymbolicArrayRepr{} -> arrayIte s + SymbolicStructRepr{} -> structIte s + RecursiveRepr nm ctx -> muxRecursive (muxRegForType s itefns) nm ctx + IntrinsicRepr nm ctx -> + case MapF.lookup nm itefns of + Just IntrinsicMuxFn -> muxIntrinsic s itefns nm ctx + Nothing -> \_ _ _ -> + panic "RegMap.muxRegForType" + [ "Unknown intrinsic type:" + , "*** Name: " ++ show nm + ] + +-- | Mux two register entries. +{-# INLINE muxRegEntry #-} +muxRegEntry :: IsSymInterface sym + => sym + -> IntrinsicTypes sym + -> MuxFn (Pred sym) (RegEntry sym tp) +muxRegEntry sym iteFns pp (RegEntry rtp x) (RegEntry _ y) = do + RegEntry rtp <$> muxRegForType sym iteFns rtp pp x y + +pushBranchRegEntry + :: (IsSymInterface sym) + => sym + -> IntrinsicTypes sym + -> RegEntry sym tp + -> IO (RegEntry sym tp) +pushBranchRegEntry sym iTypes (RegEntry tp x) = + RegEntry tp <$> pushBranchForType sym iTypes tp x + +abortBranchRegEntry + :: (IsSymInterface sym) + => sym + -> IntrinsicTypes sym + -> RegEntry sym tp + -> IO (RegEntry sym tp) +abortBranchRegEntry sym iTypes (RegEntry tp x) = + RegEntry tp <$> abortBranchForType sym iTypes tp x + + +{-# INLINE mergeRegs #-} +mergeRegs :: (IsSymInterface sym) + => sym + -> IntrinsicTypes sym + -> MuxFn (Pred sym) (RegMap sym ctx) +mergeRegs sym iTypes pp (RegMap rx) (RegMap ry) = do + RegMap <$> Ctx.zipWithM (muxRegEntry sym iTypes pp) rx ry + +{-# INLINE pushBranchRegs #-} +pushBranchRegs :: forall sym ctx + . (IsSymInterface sym) + => sym + -> IntrinsicTypes sym + -> RegMap sym ctx + -> IO (RegMap sym ctx) +pushBranchRegs sym iTypes (RegMap rx) = + RegMap <$> traverseFC (pushBranchRegEntry sym iTypes) rx + +{-# INLINE abortBranchRegs #-} +abortBranchRegs :: forall sym ctx + . (IsSymInterface sym) + => sym + -> IntrinsicTypes sym + -> RegMap sym ctx + -> IO (RegMap sym ctx) +abortBranchRegs sym iTypes (RegMap rx) = + RegMap <$> traverseFC (abortBranchRegEntry sym iTypes) rx + +------------------------------------------------------------------------ +-- Coerce a RegEntry to a SymExpr + +asSymExpr :: RegEntry sym tp -- ^ RegEntry to examine + -> (forall bt. tp ~ BaseToType bt => SymExpr sym bt -> a) + -- ^ calculate final value when the register is a SymExpr + -> a -- ^ final value to use if the register entry is not a SymExpr + -> a +asSymExpr (RegEntry tp v) just nothing = + case tp of + IntegerRepr -> just v + RealValRepr -> just v + ComplexRealRepr -> just v + BoolRepr -> just v + BVRepr _w -> just v + IEEEFloatRepr _p -> just v + _ -> nothing diff --git a/src/Lang/Crucible/Simulator/RegValue.hs b/src/Lang/Crucible/Simulator/RegValue.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/RegValue.hs @@ -0,0 +1,363 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.RegValue +-- Description : Runtime representation of CFG registers +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- RegValue is a type family that defines the runtime representation +-- of crucible types. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.RegValue + ( RegValue + , CanMux(..) + , RegValue'(..) + , MuxFn + + -- * Register values + , AnyValue(..) + , FnVal(..) + , fnValType + , RolledType(..) + , SymSequence(..) + + , VariantBranch(..) + , injectVariant + + -- * Value mux functions + , ValMuxFn + , eqMergeFn + , mergePartExpr + , muxRecursive + , muxStringMap + , muxStruct + , muxVariant + , muxVector + , muxSymSequence + , muxHandle + ) where + +import Control.Monad +import Control.Monad.Trans.Class +import Data.Kind +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Vector as V +import Data.Word +import GHC.TypeNats (KnownNat) + +import qualified Data.Parameterized.Context as Ctx + +import What4.FunctionName +import What4.Interface +import What4.InterpretedFloatingPoint +import What4.Partial +import What4.WordMap + +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.SymSequence +import Lang.Crucible.Types +import Lang.Crucible.Utils.MuxTree +import Lang.Crucible.Backend + +type MuxFn p v = p -> v -> v -> IO v + +-- | Maps register types to the runtime representation. +type family RegValue (sym :: Type) (tp :: CrucibleType) :: Type where + RegValue sym (BaseToType bt) = SymExpr sym bt + RegValue sym (FloatType fi) = SymInterpretedFloat sym fi + RegValue sym AnyType = AnyValue sym + RegValue sym UnitType = () + RegValue sym NatType = SymNat sym + RegValue sym CharType = Word16 + RegValue sym (FunctionHandleType a r) = FnVal sym a r + RegValue sym (MaybeType tp) = PartExpr (Pred sym) (RegValue sym tp) + RegValue sym (VectorType tp) = V.Vector (RegValue sym tp) + RegValue sym (SequenceType tp) = SymSequence sym (RegValue sym tp) + RegValue sym (StructType ctx) = Ctx.Assignment (RegValue' sym) ctx + RegValue sym (VariantType ctx) = Ctx.Assignment (VariantBranch sym) ctx + RegValue sym (ReferenceType tp) = MuxTree sym (RefCell tp) + RegValue sym (WordMapType w tp) = WordMap sym w tp + RegValue sym (RecursiveType nm ctx) = RolledType sym nm ctx + RegValue sym (IntrinsicType nm ctx) = Intrinsic sym nm ctx + RegValue sym (StringMapType tp) = Map Text (PartExpr (Pred sym) (RegValue sym tp)) + +-- | A newtype wrapper around RegValue. This is wrapper necessary because +-- RegValue is a type family and, as such, cannot be partially applied. +newtype RegValue' sym tp = RV { unRV :: RegValue sym tp } + +------------------------------------------------------------------------ +-- FnVal + +-- | Represents a function closure. +data FnVal (sym :: Type) (args :: Ctx CrucibleType) (res :: CrucibleType) where + ClosureFnVal :: + !(FnVal sym (args ::> tp) ret) -> + !(TypeRepr tp) -> + !(RegValue sym tp) -> + FnVal sym args ret + + VarargsFnVal :: + !(FnHandle (args ::> VectorType AnyType) ret) -> + !(CtxRepr addlArgs) -> + FnVal sym (args <+> addlArgs) ret + + HandleFnVal :: + !(FnHandle a r) -> + FnVal sym a r + + +closureFunctionName :: FnVal sym args res -> FunctionName +closureFunctionName (ClosureFnVal c _ _) = closureFunctionName c +closureFunctionName (HandleFnVal h) = handleName h +closureFunctionName (VarargsFnVal h _) = handleName h + +-- | Extract the runtime representation of the type of the given 'FnVal' +fnValType :: FnVal sym args res -> TypeRepr (FunctionHandleType args res) +fnValType (HandleFnVal h) = FunctionHandleRepr (handleArgTypes h) (handleReturnType h) +fnValType (VarargsFnVal h addlArgs) = + case handleArgTypes h of + args Ctx.:> _ -> FunctionHandleRepr (args Ctx.<++> addlArgs) (handleReturnType h) +fnValType (ClosureFnVal fn _ _) = + case fnValType fn of + FunctionHandleRepr allArgs r -> + case allArgs of + args Ctx.:> _ -> FunctionHandleRepr args r + +instance Show (FnVal sym a r) where + show = show . closureFunctionName + +-- | Version of 'MuxFn' specialized to 'RegValue' +type ValMuxFn sym tp = MuxFn (Pred sym) (RegValue sym tp) + +------------------------------------------------------------------------ +-- CanMux + +-- | A class for 'CrucibleType's that have a +-- mux function. +class CanMux sym (tp :: CrucibleType) where + muxReg :: sym + -> p tp -- ^ Unused type to identify what is being merged. + -> ValMuxFn sym tp + +-- | Merge function that checks if two values are equal, and +-- fails if they are not. +{-# INLINE eqMergeFn #-} +eqMergeFn :: (IsExprBuilder sym, Eq v) => sym -> String -> MuxFn p v +eqMergeFn sym nm = \_ x y -> + if x == y then + return x + else + throwUnsupported sym $ "Cannot merge dissimilar " ++ nm ++ "." + +------------------------------------------------------------------------ +-- RegValue AnyType instance + +data AnyValue sym where + AnyValue :: TypeRepr tp -> RegValue sym tp -> AnyValue sym + +------------------------------------------------------------------------ +-- RegValue () instance + +instance CanMux sym UnitType where + muxReg _ = \_ _ x _y -> return x + +------------------------------------------------------------------------ +-- RegValue instance for base types + +instance IsExprBuilder sym => CanMux sym BoolType where + {-# INLINE muxReg #-} + muxReg s = const $ itePred s + +instance IsExprBuilder sym => CanMux sym NatType where + {-# INLINE muxReg #-} + muxReg s = \_ -> natIte s + +instance IsExprBuilder sym => CanMux sym IntegerType where + {-# INLINE muxReg #-} + muxReg s = \_ -> intIte s + +instance IsExprBuilder sym => CanMux sym RealValType where + {-# INLINE muxReg #-} + muxReg s = \_ -> realIte s + +instance IsInterpretedFloatExprBuilder sym => CanMux sym (FloatType fi) where + {-# INLINE muxReg #-} + muxReg s = \_ -> iFloatIte @sym @fi s + +instance IsExprBuilder sym => CanMux sym ComplexRealType where + {-# INLINE muxReg #-} + muxReg s = \_ -> cplxIte s + +instance IsExprBuilder sym => CanMux sym (StringType si) where + {-# INLINE muxReg #-} + muxReg s = \_ -> stringIte s + +instance IsExprBuilder sym => CanMux sym (IEEEFloatType fpp) where + muxReg s = \_ -> floatIte s + +------------------------------------------------------------------------ +-- RegValue Vector instance + +{-# INLINE muxVector #-} +muxVector :: IsExprBuilder sym => + sym -> MuxFn p e -> MuxFn p (V.Vector e) +muxVector sym f p x y + | V.length x == V.length y = V.zipWithM (f p) x y + | otherwise = + throwUnsupported sym "Cannot merge vectors with different dimensions." + +instance (IsSymInterface sym, CanMux sym tp) => CanMux sym (VectorType tp) where + {-# INLINE muxReg #-} + muxReg s _ = muxVector s (muxReg s (Proxy :: Proxy tp)) + +------------------------------------------------------------------------ +-- RegValue WordMap instance + +instance (IsExprBuilder sym, KnownNat w, KnownRepr BaseTypeRepr tp) + => CanMux sym (WordMapType w tp) where + {-# INLINE muxReg #-} + muxReg s _ p = muxWordMap s knownNat knownRepr p + +------------------------------------------------------------------------ +-- RegValue MatlabChar instance + +instance IsSymInterface sym => CanMux sym CharType where + {-# INLINE muxReg #-} + muxReg s = \_ -> eqMergeFn s "characters" + +------------------------------------------------------------------------ +-- RegValue Maybe instance + +mergePartExpr :: IsExprBuilder sym + => sym + -> (Pred sym -> v -> v -> IO v) + -> Pred sym + -> PartExpr (Pred sym) v + -> PartExpr (Pred sym) v + -> IO (PartExpr (Pred sym) v) +mergePartExpr sym fn = mergePartial sym (\c a b -> lift (fn c a b)) + +instance (IsExprBuilder sym, CanMux sym tp) => CanMux sym (MaybeType tp) where + {-# INLINE muxReg #-} + muxReg s = \_ -> do + let f = muxReg s (Proxy :: Proxy tp) + in mergePartExpr s f + +------------------------------------------------------------------------ +-- RegValue FunctionHandleType instance + +-- TODO: Figure out how to actually compare these. +{-# INLINE muxHandle #-} +muxHandle :: IsExpr (SymExpr sym) + => sym + -> Pred sym + -> FnVal sym a r + -> FnVal sym a r + -> IO (FnVal sym a r) +muxHandle _ c x y + | Just b <- asConstantPred c = pure $! if b then x else y + | otherwise = return x + +instance IsExprBuilder sym => CanMux sym (FunctionHandleType a r) where + {-# INLINE muxReg #-} + muxReg s = \_ c x y -> do + muxHandle s c x y + +------------------------------------------------------------------------ +-- RegValue IdentValueMap instance + +-- | Merge to string maps together. +{-# INLINE muxStringMap #-} +muxStringMap :: IsExprBuilder sym + => sym + -> MuxFn (Pred sym) e + -> MuxFn (Pred sym) (Map Text (PartExpr (Pred sym) e)) +muxStringMap sym = \f c x y -> do + let keys = Set.toList $ Set.union (Map.keysSet x) (Map.keysSet y) + fmap Map.fromList $ forM keys $ \k -> do + let vx = joinMaybePE (Map.lookup k x) + let vy = joinMaybePE (Map.lookup k y) + r <- mergePartExpr sym f c vx vy + return (k,r) + +------------------------------------------------------------------------ +-- RegValue Recursive instance + +newtype RolledType sym nm ctx = RolledType { unroll :: RegValue sym (UnrollType nm ctx) } + + +{-# INLINE muxRecursive #-} +muxRecursive + :: IsRecursiveType nm + => (forall tp. TypeRepr tp -> ValMuxFn sym tp) + -> SymbolRepr nm + -> CtxRepr ctx + -> ValMuxFn sym (RecursiveType nm ctx) +muxRecursive recf = \nm ctx p x y -> do + RolledType <$> recf (unrollType nm ctx) p (unroll x) (unroll y) + +------------------------------------------------------------------------ +-- RegValue Struct instance + +{-# INLINE muxStruct #-} +muxStruct + :: (forall tp. TypeRepr tp -> ValMuxFn sym tp) + -> CtxRepr ctx + -> ValMuxFn sym (StructType ctx) +muxStruct recf ctx = \p x y -> + Ctx.generateM (Ctx.size ctx) $ \i -> do + RV <$> recf (ctx Ctx.! i) p (unRV $ x Ctx.! i) (unRV $ y Ctx.! i) + +------------------------------------------------------------------------ +-- RegValue Variant instance + +newtype VariantBranch sym tp = VB { unVB :: PartExpr (Pred sym) (RegValue sym tp) } + +-- | Construct a 'VariantType' value by identifying which branch of +-- the variant to construct, and providing a value of the correct type. +injectVariant :: + IsExprBuilder sym => + sym {- ^ symbolic backend -} -> + CtxRepr ctx {- ^ Types of the variant branches -} -> + Ctx.Index ctx tp {- ^ Which branch -} -> + RegValue sym tp {- ^ The value to inject -} -> + RegValue sym (VariantType ctx) +injectVariant sym ctxRepr idx val = + Ctx.generate (Ctx.size ctxRepr) $ \j -> + case testEquality j idx of + Just Refl -> VB (PE (truePred sym) val) + Nothing -> VB Unassigned + + +{-# INLINE muxVariant #-} +muxVariant + :: IsExprBuilder sym + => sym + -> (forall tp. TypeRepr tp -> ValMuxFn sym tp) + -> CtxRepr ctx + -> ValMuxFn sym (VariantType ctx) +muxVariant sym recf ctx = \p x y -> + Ctx.generateM (Ctx.size ctx) $ \i -> + VB <$> mergePartExpr sym + (recf (ctx Ctx.! i)) + p + (unVB (x Ctx.! i)) + (unVB (y Ctx.! i)) diff --git a/src/Lang/Crucible/Simulator/SimError.hs b/src/Lang/Crucible/Simulator/SimError.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/SimError.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Simulator.SimError +-- Description : Data structure the execution state of the simulator +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Simulator.SimError ( + SimErrorReason(..) + , SimError(..) + , simErrorReasonMsg + , simErrorDetailsMsg + , ppSimError + ) where + +import GHC.Stack (CallStack) + +import Control.Exception +import Data.String +import Data.Typeable +import Prettyprinter + +import What4.ProgramLoc + +------------------------------------------------------------------------ +-- SimError + +-- | Class for exceptions generated by simulator. +data SimErrorReason + = GenericSimError !String + | Unsupported !CallStack !String + -- ^ We can't do that (yet?). The call stack identifies where in the + -- Haskell code the error occured. + | ReadBeforeWriteSimError !String -- FIXME? include relevant data instead of a string? + | AssertFailureSimError !String !String + -- ^ An assertion failed. The first parameter is a short + -- description. The second is a more detailed explanation. + | ResourceExhausted String + -- ^ A loop iteration count, or similar resource limit, + -- was exceeded. + deriving (Typeable) + +data SimError + = SimError + { simErrorLoc :: !ProgramLoc + , simErrorReason :: !SimErrorReason + } + deriving (Typeable) + +simErrorReasonMsg :: SimErrorReason -> String +simErrorReasonMsg (GenericSimError msg) = msg +simErrorReasonMsg (Unsupported _ msg) = "Unsupported feature: " ++ msg +simErrorReasonMsg (ReadBeforeWriteSimError msg) = msg +simErrorReasonMsg (AssertFailureSimError msg _) = msg +simErrorReasonMsg (ResourceExhausted msg) = "Resource exhausted: " ++ msg + +simErrorDetailsMsg :: SimErrorReason -> String +simErrorDetailsMsg (AssertFailureSimError _ msg) = msg +simErrorDetailsMsg (Unsupported stk _) = show stk +simErrorDetailsMsg _ = "" + +instance IsString SimErrorReason where + fromString = GenericSimError + +instance Show SimErrorReason where + show = simErrorReasonMsg + +instance Show SimError where + show = show . ppSimError + +ppSimError :: SimError -> Doc ann +ppSimError er = + vcat $ [ pretty (plSourceLoc loc) <> pretty ": error: in" <+> pretty (plFunction loc) + , pretty (simErrorReasonMsg rsn) + ] ++ if null details + then [] + else [ pretty "Details:" + , indent 2 (vcat (pretty <$> lines details)) + ] + where loc = simErrorLoc er + details = simErrorDetailsMsg rsn + rsn = simErrorReason er + +instance Exception SimError diff --git a/src/Lang/Crucible/Simulator/SymSequence.hs b/src/Lang/Crucible/Simulator/SymSequence.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Simulator/SymSequence.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- Needed for Pretty instance +{-# LANGUAGE UndecidableInstances #-} +module Lang.Crucible.Simulator.SymSequence +( SymSequence(..) +, nilSymSequence +, consSymSequence +, appendSymSequence +, muxSymSequence +, isNilSymSequence +, lengthSymSequence +, headSymSequence +, tailSymSequence +, unconsSymSequence +, traverseSymSequence +, concreteizeSymSequence +, prettySymSequence + + -- * Low-level evaluation primitives +, newSeqCache +, evalWithCache +, evalWithFreshCache +) where + +import Control.Monad.State +import Data.Functor.Const +import Data.Kind (Type) +import Data.IORef +import Data.Maybe (isJust) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Parameterized.Nonce +import qualified Data.Parameterized.Map as MapF +import Prettyprinter (Doc) +import qualified Prettyprinter as PP + +import Lang.Crucible.Types +import What4.Interface +import What4.Partial + +------------------------------------------------------------------------ +-- SymSequence + +-- | A symbolic sequence of values supporting efficent merge operations. +-- Semantically, these are essentially cons-lists, and designed to +-- support access from the front only. Nodes carry nonce values +-- that allow DAG-based traversal, which efficently supports the common +-- case where merged nodes share a common sublist. +data SymSequence sym a where + SymSequenceNil :: SymSequence sym a + + SymSequenceCons :: + !(Nonce GlobalNonceGenerator a) -> + a -> + !(SymSequence sym a) -> + SymSequence sym a + + SymSequenceAppend :: + !(Nonce GlobalNonceGenerator a) -> + !(SymSequence sym a) -> + !(SymSequence sym a) -> + SymSequence sym a + + SymSequenceMerge :: + !(Nonce GlobalNonceGenerator a) -> + !(Pred sym) -> + !(SymSequence sym a) -> + !(SymSequence sym a) -> + SymSequence sym a + +instance Eq (SymSequence sym a) where + SymSequenceNil == SymSequenceNil = True + (SymSequenceCons n1 _ _) == (SymSequenceCons n2 _ _) = + isJust (testEquality n1 n2) + (SymSequenceMerge n1 _ _ _) == (SymSequenceMerge n2 _ _ _) = + isJust (testEquality n1 n2) + (SymSequenceAppend n1 _ _) == (SymSequenceAppend n2 _ _) = + isJust (testEquality n1 n2) + _ == _ = False + +-- | Compute an if/then/else on symbolic sequences. +-- This will simply produce an internal merge node +-- except in the special case where the then and +-- else branches are sytactically identical. +muxSymSequence :: + sym -> + Pred sym -> + SymSequence sym a -> + SymSequence sym a -> + IO (SymSequence sym a) +muxSymSequence _sym p x y + | x == y = pure x + | otherwise = + do n <- freshNonce globalNonceGenerator + pure (SymSequenceMerge n p x y) + +newtype SeqCache (f :: Type -> Type) + = SeqCache (IORef (MapF.MapF (Nonce GlobalNonceGenerator) f)) + +newSeqCache :: IO (SeqCache f) +newSeqCache = SeqCache <$> newIORef MapF.empty + +-- | Compute the nonce of a sequence, if it has one +symSequenceNonce :: SymSequence sym a -> Maybe (Nonce GlobalNonceGenerator a) +symSequenceNonce SymSequenceNil = Nothing +symSequenceNonce (SymSequenceCons n _ _ ) = Just n +symSequenceNonce (SymSequenceAppend n _ _) = Just n +symSequenceNonce (SymSequenceMerge n _ _ _) = Just n + +{-# SPECIALIZE + evalWithFreshCache :: + ((SymSequence sym a -> IO (f a)) -> SymSequence sym a -> IO (f a)) -> + (SymSequence sym a -> IO (f a)) + #-} + +evalWithFreshCache :: MonadIO m => + ((SymSequence sym a -> m (f a)) -> SymSequence sym a -> m (f a)) -> + (SymSequence sym a -> m (f a)) +evalWithFreshCache fn s = + do c <- liftIO newSeqCache + evalWithCache c fn s + +{-# SPECIALIZE + evalWithCache :: + SeqCache f -> + ((SymSequence sym a -> IO (f a)) -> SymSequence sym a -> IO (f a)) -> + (SymSequence sym a -> IO (f a)) + #-} + +evalWithCache :: MonadIO m => + SeqCache f -> + ((SymSequence sym a -> m (f a)) -> SymSequence sym a -> m (f a)) -> + (SymSequence sym a -> m (f a)) +evalWithCache (SeqCache ref) fn = loop + where + loop s + | Just n <- symSequenceNonce s = + (MapF.lookup n <$> liftIO (readIORef ref)) >>= \case + Just v -> pure v + Nothing -> + do v <- fn loop s + liftIO (modifyIORef ref (MapF.insert n v)) + pure v + + | otherwise = fn loop s + +-- | Generate an empty sequence value +nilSymSequence :: sym -> IO (SymSequence sym a) +nilSymSequence _sym = pure SymSequenceNil + +-- | Cons a new value onto the front of a sequence +consSymSequence :: + sym -> + a -> + SymSequence sym a -> + IO (SymSequence sym a) +consSymSequence _sym x xs = + do n <- freshNonce globalNonceGenerator + pure (SymSequenceCons n x xs) + +-- | Append two sequences +appendSymSequence :: + sym -> + SymSequence sym a {- ^ front sequence -} -> + SymSequence sym a {- ^ back sequence -} -> + IO (SymSequence sym a) + +-- special cases, nil is the unit for append +appendSymSequence _ xs SymSequenceNil = pure xs +appendSymSequence _ SymSequenceNil ys = pure ys +-- special case, append of a singleton is cons +appendSymSequence sym (SymSequenceCons _ v SymSequenceNil) xs = + consSymSequence sym v xs +appendSymSequence _sym xs ys = + do n <- freshNonce globalNonceGenerator + pure (SymSequenceAppend n xs ys) + + +-- | Test if a sequence is nil (is empty) +isNilSymSequence :: forall sym a. + IsExprBuilder sym => + sym -> + SymSequence sym a -> + IO (Pred sym) +isNilSymSequence sym = \s -> getConst <$> evalWithFreshCache f s + where + f :: (SymSequence sym tp -> IO (Const (Pred sym) tp)) -> (SymSequence sym tp -> IO (Const (Pred sym) tp)) + f _loop SymSequenceNil{} = pure (Const (truePred sym)) + f _loop SymSequenceCons{} = pure (Const (falsePred sym)) + f loop (SymSequenceAppend _ xs ys) = + do px <- getConst <$> loop xs + Const <$> itePredM sym px (getConst <$> loop ys) (pure (falsePred sym)) + f loop (SymSequenceMerge _ p xs ys) = + Const <$> itePredM sym p (getConst <$> loop xs) (getConst <$> loop ys) + + +-- | Compute the length of a sequence +lengthSymSequence :: forall sym a. + IsExprBuilder sym => + sym -> + SymSequence sym a -> + IO (SymNat sym) +lengthSymSequence sym = \s -> getConst <$> evalWithFreshCache f s + where + f :: (SymSequence sym a -> IO (Const (SymNat sym) a)) -> (SymSequence sym a -> IO (Const (SymNat sym) a)) + f _loop SymSequenceNil = Const <$> natLit sym 0 + f loop (SymSequenceCons _ _ tl) = + do x <- getConst <$> loop tl + one <- natLit sym 1 + Const <$> natAdd sym one x + f loop (SymSequenceMerge _ p xs ys) = + do x <- getConst <$> loop xs + y <- getConst <$> loop ys + Const <$> natIte sym p x y + f loop (SymSequenceAppend _ xs ys) = + do x <- getConst <$> loop xs + y <- getConst <$> loop ys + Const <$> natAdd sym x y + + +newtype SeqHead sym a = SeqHead { getSeqHead :: PartExpr (Pred sym) a } + +-- | Compute the head of a sequence, if it has one +headSymSequence :: forall sym a. + IsExprBuilder sym => + sym -> + (Pred sym -> a -> a -> IO a) {- ^ mux function on values -} -> + SymSequence sym a -> + IO (PartExpr (Pred sym) a) +headSymSequence sym mux = \s -> getSeqHead <$> evalWithFreshCache f s + where + f' :: Pred sym -> a -> a -> PartialT sym IO a + f' c x y = PartialT (\_ p -> PE p <$> mux c x y) + + f :: (SymSequence sym a -> IO (SeqHead sym a)) -> (SymSequence sym a -> IO (SeqHead sym a)) + f _loop SymSequenceNil = pure (SeqHead Unassigned) + f _loop (SymSequenceCons _ v _) = pure (SeqHead (justPartExpr sym v)) + f loop (SymSequenceMerge _ p xs ys) = + do mhx <- getSeqHead <$> loop xs + mhy <- getSeqHead <$> loop ys + SeqHead <$> mergePartial sym f' p mhx mhy + + f loop (SymSequenceAppend _ xs ys) = + loop xs >>= \case + SeqHead Unassigned -> loop ys + SeqHead (PE px hx) + | Just True <- asConstantPred px -> pure (SeqHead (PE px hx)) + | otherwise -> + loop ys >>= \case + SeqHead Unassigned -> pure (SeqHead (PE px hx)) + SeqHead (PE py hy) -> + do p <- orPred sym px py + SeqHead <$> runPartialT sym p (f' px hx hy) + +newtype SeqUncons sym a = + SeqUncons + { getSeqUncons :: PartExpr (Pred sym) (a, SymSequence sym a) + } + +-- | Compute both the head and the tail of a sequence, if it is nonempty +unconsSymSequence :: forall sym a. + IsExprBuilder sym => + sym -> + (Pred sym -> a -> a -> IO a) {- ^ mux function on values -} -> + SymSequence sym a -> + IO (PartExpr (Pred sym) (a, SymSequence sym a)) +unconsSymSequence sym mux = \s -> getSeqUncons <$> evalWithFreshCache f s + where + f' :: Pred sym -> + (a, SymSequence sym a) -> + (a, SymSequence sym a) -> + PartialT sym IO (a, SymSequence sym a) + f' c x y = PartialT $ \_ p -> PE p <$> + do h <- mux c (fst x) (fst y) + tl <- muxSymSequence sym c (snd x) (snd y) + pure (h, tl) + + f :: (SymSequence sym a -> IO (SeqUncons sym a)) -> (SymSequence sym a -> IO (SeqUncons sym a)) + f _loop SymSequenceNil = pure (SeqUncons Unassigned) + f _loop (SymSequenceCons _ v tl) = pure (SeqUncons (justPartExpr sym (v, tl))) + f loop (SymSequenceMerge _ p xs ys) = + do ux <- getSeqUncons <$> loop xs + uy <- getSeqUncons <$> loop ys + SeqUncons <$> mergePartial sym f' p ux uy + + f loop (SymSequenceAppend _ xs ys) = + loop xs >>= \case + SeqUncons Unassigned -> loop ys + SeqUncons (PE px ux) + | Just True <- asConstantPred px -> + do t <- appendSymSequence sym (snd ux) ys + pure (SeqUncons (PE px (fst ux, t))) + + | otherwise -> + loop ys >>= \case + SeqUncons Unassigned -> pure (SeqUncons (PE px ux)) + SeqUncons (PE py uy) -> + do p <- orPred sym px py + t <- appendSymSequence sym (snd ux) ys + let ux' = (fst ux, t) + SeqUncons <$> runPartialT sym p (f' px ux' uy) + +newtype SeqTail sym tp = + SeqTail + { getSeqTail :: PartExpr (Pred sym) (SymSequence sym tp) } + +-- | Compute the tail of a sequence, if it has one +tailSymSequence :: forall sym a. + IsExprBuilder sym => + sym -> + SymSequence sym a -> + IO (PartExpr (Pred sym) (SymSequence sym a)) +tailSymSequence sym = \s -> getSeqTail <$> evalWithFreshCache f s + where + f' :: Pred sym -> + SymSequence sym a -> + SymSequence sym a -> + PartialT sym IO (SymSequence sym a) + f' c x y = PartialT $ \_ p -> PE p <$> muxSymSequence sym c x y + + f :: (SymSequence sym a -> IO (SeqTail sym a)) -> (SymSequence sym a -> IO (SeqTail sym a)) + f _loop SymSequenceNil = pure (SeqTail Unassigned) + f _loop (SymSequenceCons _ _v tl) = pure (SeqTail (justPartExpr sym tl)) + f loop (SymSequenceMerge _ p xs ys) = + do tx <- getSeqTail <$> loop xs + ty <- getSeqTail <$> loop ys + SeqTail <$> mergePartial sym f' p tx ty + f loop (SymSequenceAppend _ xs ys) = + loop xs >>= \case + SeqTail Unassigned -> loop ys + SeqTail (PE px tx) + | Just True <- asConstantPred px -> + do t <- appendSymSequence sym tx ys + pure (SeqTail (PE px t)) + + | otherwise -> + loop ys >>= \case + SeqTail Unassigned -> pure (SeqTail (PE px tx)) + SeqTail (PE py ty) -> + do p <- orPred sym px py + t <- appendSymSequence sym tx ys + SeqTail <$> runPartialT sym p (f' px t ty) + + +{-# SPECIALIZE + traverseSymSequence :: + sym -> + (a -> IO b) -> + SymSequence sym a -> + IO (SymSequence sym b) + #-} + +-- | Visit every element in the given symbolic sequence, +-- applying the given action, and constructing a new +-- sequence. The traversal is memoized, so any given +-- subsequence will be visited at most once. +traverseSymSequence :: forall m sym a b. + MonadIO m => + sym -> + (a -> m b) -> + SymSequence sym a -> + m (SymSequence sym b) +traverseSymSequence sym f = \s -> getConst <$> evalWithFreshCache fn s + where + fn :: (SymSequence sym a -> m (Const (SymSequence sym b) a)) -> + (SymSequence sym a -> m (Const (SymSequence sym b) a)) + fn _loop SymSequenceNil = pure (Const SymSequenceNil) + fn loop (SymSequenceCons _ v tl) = + do v' <- f v + tl' <- getConst <$> loop tl + liftIO (Const <$> consSymSequence sym v' tl') + fn loop (SymSequenceAppend _ xs ys) = + do xs' <- getConst <$> loop xs + ys' <- getConst <$> loop ys + liftIO (Const <$> appendSymSequence sym xs' ys') + fn loop (SymSequenceMerge _ p xs ys) = + do xs' <- getConst <$> loop xs + ys' <- getConst <$> loop ys + liftIO (Const <$> muxSymSequence sym p xs' ys') + + +-- | Using the given evaluation function for booleans, and an evaluation +-- function for values, compute a concrete sequence corresponding +-- to the given symbolic sequence. +concreteizeSymSequence :: + (Pred sym -> IO Bool) {- ^ evaluation for booleans -} -> + (a -> IO b) {- ^ evaluation for values -} -> + SymSequence sym a -> IO [b] +concreteizeSymSequence conc eval = loop + where + loop SymSequenceNil = pure [] + loop (SymSequenceCons _ v tl) = (:) <$> eval v <*> loop tl + loop (SymSequenceAppend _ xs ys) = (++) <$> loop xs <*> loop ys + loop (SymSequenceMerge _ p xs ys) = + do b <- conc p + if b then loop xs else loop ys + +instance (IsExpr (SymExpr sym), PP.Pretty a) => PP.Pretty (SymSequence sym a) where + pretty = prettySymSequence PP.pretty + +-- | Given a pretty printer for elements, +-- print a symbolic sequence. +prettySymSequence :: IsExpr (SymExpr sym) => + (a -> Doc ann) -> + SymSequence sym a -> + Doc ann +prettySymSequence ppa s = if Map.null bs then x else letlayout + where + occMap = computeOccMap s mempty + (x,bs) = runState (prettyAux ppa occMap s) mempty + letlayout = PP.vcat + ["let" PP.<+> (PP.align (PP.vcat [ letbind n d | (n,d) <- Map.toList bs ])) + ," in" PP.<+> x + ] + letbind n d = ppSeqNonce n PP.<+> "=" PP.<+> PP.align d + +computeOccMap :: + SymSequence sym a -> + Map (Nonce GlobalNonceGenerator a) Integer -> + Map (Nonce GlobalNonceGenerator a) Integer +computeOccMap = loop + where + visit n k m + | Just i <- Map.lookup n m = Map.insert n (i+1) m + | otherwise = k (Map.insert n 1 m) + + loop SymSequenceNil = id + loop (SymSequenceCons n _ tl) = visit n (loop tl) + loop (SymSequenceAppend n xs ys) = visit n (loop xs . loop ys) + loop (SymSequenceMerge n _ xs ys) = visit n (loop xs . loop ys) + +ppSeqNonce :: Nonce GlobalNonceGenerator a -> Doc ann +ppSeqNonce n = "s" <> PP.viaShow (indexValue n) + +prettyAux :: + IsExpr (SymExpr sym) => + (a -> Doc ann) -> + Map (Nonce GlobalNonceGenerator a) Integer -> + SymSequence sym a -> + State (Map (Nonce GlobalNonceGenerator a) (Doc ann)) (Doc ann) +prettyAux ppa occMap = goTop + where + goTop SymSequenceNil = pure (PP.list []) + goTop (SymSequenceCons _ v tl) = pp [] [v] [tl] + goTop (SymSequenceAppend _ xs ys) = pp [] [] [xs,ys] + goTop (SymSequenceMerge _ p xs ys) = + do xd <- pp [] [] [xs] + yd <- pp [] [] [ys] + pure $ {- PP.group $ -} PP.hang 2 $ PP.vsep + [ "if" PP.<+> printSymExpr p + , "then" PP.<+> xd + , "else" PP.<+> yd + ] + + visit n s = + do dm <- get + case Map.lookup n dm of + Just _ -> return () + Nothing -> + do d <- goTop s + modify (Map.insert n d) + return (ppSeqNonce n) + + finalize [] = PP.list [] + finalize [x] = x + finalize xs = PP.sep (PP.punctuate (PP.space <> "<>") (reverse xs)) + + elemSeq rs = PP.list (map ppa (reverse rs)) + + addSeg segs [] seg = (seg : segs) + addSeg segs rs seg = (seg : elemSeq rs : segs) + + -- @pp@ accumulates both "segments" of sequences (segs) + -- and individual values (rs) to be output. Both are + -- in reversed order. Segments represent sequences + -- and must be combined with the append operator, + -- and rs represent individual elements that must be combined + -- with cons (or, in actuality, list syntax with brackets and commas). + + -- @pp@ works over a list of SymSequence values, which represent a worklist + -- of segments to process. Morally, the invariant of @pp@ is that the + -- arguments always represent the same sequence, which is computed as + -- @concat (reverse segs) ++ reverse rs ++ concat ss@ + + pp segs [] [] = pure (finalize segs) + pp segs rs [] = pure (finalize ( elemSeq rs : segs )) + + pp segs rs (SymSequenceNil:ss) = pp segs rs ss + + pp segs rs (s@(SymSequenceCons n v tl) : ss) + | Just i <- Map.lookup n occMap, i > 1 + = do x <- visit n s + pp (addSeg segs rs x) [] ss + + | otherwise + = pp segs (v : rs) (tl : ss) + + pp segs rs (s@(SymSequenceAppend n xs ys) : ss) + | Just i <- Map.lookup n occMap, i > 1 + = do x <- visit n s + pp (addSeg segs rs x) [] ss + + | otherwise + = pp segs rs (xs:ys:ss) + + pp segs rs (s@(SymSequenceMerge n _ _ _) : ss) + = do x <- visit n s + pp (addSeg segs rs x) [] ss diff --git a/src/Lang/Crucible/Syntax.hs b/src/Lang/Crucible/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Syntax.hs @@ -0,0 +1,541 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Syntax +-- Description : Provides a typeclass and methods for constructing +-- AST expressions. +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides typeclasses and combinators for constructing AST +-- expressions. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +module Lang.Crucible.Syntax + ( IsExpr(..) + , eapp + , asEapp + -- * Booleans + , true + , false + , notExpr + , (.&&) + , (.||) + -- * Expression classes + , EqExpr(..) + , OrdExpr(..) + , NumExpr(..) + , LitExpr(..) + -- * Natural numbers + , ConvertableToNat(..) + -- * Real numbers + , rationalLit + , natToReal + , integerToReal + -- * Complex real numbers + , realToCplx + , imagToCplx + , realPart + , imagPart + , realLit + , imagLit + , natToCplx + -- * Maybe + , nothingValue + , justValue + -- * Vector + , vectorSize + , vectorLit + , vectorGetEntry + , vectorSetEntry + , vectorIsEmpty + , vecReplicate + -- * Function handles + , closure + -- * IdentValueMap + , emptyIdentValueMap + , setIdentValue + + -- * Structs + , mkStruct + , getStruct + , setStruct + + -- * Multibyte operations + , concatExprs + , bigEndianLoad + , bigEndianLoadDef + , bigEndianStore + , littleEndianLoad + , littleEndianLoadDef + , littleEndianStore + ) where + +import Control.Lens +import qualified Data.BitVector.Sized as BV +import Data.Kind +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some +import Data.Text (Text) +import qualified Data.Vector as V +import Numeric.Natural + +import Lang.Crucible.CFG.Expr +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types + +import What4.Utils.StringLiteral + +------------------------------------------------------------------------ +-- IsExpr + +-- | A typeclass for injecting applications into expressions. +class IsExpr e where + type ExprExt e :: Type + app :: App (ExprExt e) e tp -> e tp + asApp :: e tp -> Maybe (App (ExprExt e) e tp) + exprType :: e tp -> TypeRepr tp + +-- | Inject an extension app into the expression type +eapp :: IsExpr e => ExprExtension (ExprExt e) e tp -> e tp +eapp = app . ExtensionApp + +-- | Test if an expression is formed from an extension app +asEapp :: IsExpr e => e tp -> Maybe (ExprExtension (ExprExt e) e tp) +asEapp e = + case asApp e of + Just (ExtensionApp x) -> Just x + _ -> Nothing + +------------------------------------------------------------------------ +-- LitExpr + +-- | An expression that embeds literal values of its type. +class LitExpr e tp ty | tp -> ty where + litExpr :: IsExpr e => ty -> e tp + +------------------------------------------------------------------------ +-- Booleans + +instance LitExpr e BoolType Bool where + litExpr b = app (BoolLit b) + +-- | True expression +true :: IsExpr e => e BoolType +true = litExpr True + +-- | False expression +false :: IsExpr e => e BoolType +false = litExpr False + +notExpr :: IsExpr e => e BoolType -> e BoolType +notExpr x = app (Not x) + +(.&&) :: IsExpr e => e BoolType -> e BoolType -> e BoolType +(.&&) x y = app (And x y) + +(.||) :: IsExpr e => e BoolType -> e BoolType -> e BoolType +(.||) x y = app (Or x y) + +infixr 3 .&& +infixr 2 .|| + +------------------------------------------------------------------------ +-- EqExpr + +class EqExpr e tp where + (.==) :: IsExpr e => e tp -> e tp -> e BoolType + + (./=) :: IsExpr e => e tp -> e tp -> e BoolType + x ./= y = notExpr (x .== y) + +infix 4 .== +infix 4 ./= + +------------------------------------------------------------------------ +-- OrdExpr + +class EqExpr e tp => OrdExpr e tp where + (.<) :: IsExpr e => e tp -> e tp -> e BoolType + + (.<=) :: IsExpr e => e tp -> e tp -> e BoolType + x .<= y = notExpr (y .< x) + + (.>) :: IsExpr e => e tp -> e tp -> e BoolType + x .> y = y .< x + + (.>=) :: IsExpr e => e tp -> e tp -> e BoolType + x .>= y = y .<= x + +infix 4 .< +infix 4 .<= +infix 4 .> +infix 4 .>= + +------------------------------------------------------------------------ +-- NumExpr + +class NumExpr e tp where + (.+) :: IsExpr e => e tp -> e tp -> e tp + (.-) :: IsExpr e => e tp -> e tp -> e tp + (.*) :: IsExpr e => e tp -> e tp -> e tp + +------------------------------------------------------------------------ +-- Nat + +instance LitExpr e NatType Natural where + litExpr n = app (NatLit n) + +instance EqExpr e NatType where + x .== y = app (NatEq x y) + +instance OrdExpr e NatType where + x .< y = app (NatLt x y) + +instance NumExpr e NatType where + x .+ y = app (NatAdd x y) + x .- y = app (NatSub x y) + x .* y = app (NatMul x y) + +------------------------------------------------------------------------ +-- Integer + +instance LitExpr e IntegerType Integer where + litExpr x = app (IntLit x) + +------------------------------------------------------------------------ +-- ConvertableToNat + +class ConvertableToNat e tp where + -- | Convert value of type to Nat. + -- This may be partial, it is the responsibility of the calling + -- code that it is correct for this type. + toNat :: IsExpr e => e tp -> e NatType + +------------------------------------------------------------------------ +-- RealValType + +rationalLit :: IsExpr e => Rational -> e RealValType +rationalLit v = app (RationalLit v) + +instance EqExpr e RealValType where + x .== y = app (RealEq x y) + +instance OrdExpr e RealValType where + x .< y = app (RealLt x y) + +natToInteger :: IsExpr e => e NatType -> e IntegerType +natToInteger x = app (NatToInteger x) + +integerToReal :: IsExpr e => e IntegerType -> e RealValType +integerToReal x = app (IntegerToReal x) + +natToReal :: IsExpr e => e NatType -> e RealValType +natToReal = integerToReal . natToInteger + +instance ConvertableToNat e RealValType where + toNat v = app (RealToNat v) + +------------------------------------------------------------------------ +-- ComplexRealType + +realToCplx :: IsExpr e => e RealValType -> e ComplexRealType +realToCplx v = app (Complex v (rationalLit 0)) + +imagToCplx :: IsExpr e => e RealValType -> e ComplexRealType +imagToCplx v = app (Complex (rationalLit 0) v) + +realPart :: IsExpr e => e ComplexRealType -> e RealValType +realPart c = app (RealPart c) + +imagPart :: IsExpr e => e ComplexRealType -> e RealValType +imagPart c = app (ImagPart c) + +realLit :: IsExpr e => Rational -> e ComplexRealType +realLit = realToCplx . rationalLit + +imagLit :: IsExpr e => Rational -> e ComplexRealType +imagLit = imagToCplx . rationalLit + +natToCplx :: IsExpr e => e NatType -> e ComplexRealType +natToCplx = realToCplx . natToReal + +instance ConvertableToNat e ComplexRealType where + toNat = toNat . realPart + +------------------------------------------------------------------------ +-- String + +instance LitExpr e (StringType Unicode) Text where + litExpr t = app (StringLit (UnicodeLiteral t)) + +------------------------------------------------------------------------ +-- Maybe + +nothingValue :: (IsExpr e, KnownRepr TypeRepr tp) => e (MaybeType tp) +nothingValue = app (NothingValue knownRepr) + +justValue :: (IsExpr e, KnownRepr TypeRepr tp) => e tp -> e (MaybeType tp) +justValue x = app (JustValue knownRepr x) + +------------------------------------------------------------------------ +-- Vector + +vectorSize :: (IsExpr e) => e (VectorType tp) -> e NatType +vectorSize v = app (VectorSize v) + +vectorIsEmpty :: (IsExpr e) => e (VectorType tp) -> e BoolType +vectorIsEmpty v = app (VectorIsEmpty v) + +vectorLit :: (IsExpr e) => TypeRepr tp -> V.Vector (e tp) -> e (VectorType tp) +vectorLit tp v = app (VectorLit tp v) + +-- | Get the entry from a zero-based index. +vectorGetEntry :: (IsExpr e, KnownRepr TypeRepr tp) => e (VectorType tp) -> e NatType -> e tp +vectorGetEntry v i = app (VectorGetEntry knownRepr v i) + +vectorSetEntry :: (IsExpr e, KnownRepr TypeRepr tp ) + => e (VectorType tp) + -> e NatType + -> e tp + -> e (VectorType tp) +vectorSetEntry v i x = app (VectorSetEntry knownRepr v i x) + +vecReplicate :: (IsExpr e, KnownRepr TypeRepr tp) => e NatType -> e tp -> e (VectorType tp) +vecReplicate n v = app (VectorReplicate knownRepr n v) + +------------------------------------------------------------------------ +-- Handles + +instance LitExpr e (FunctionHandleType args ret) (FnHandle args ret) where + litExpr h = app (HandleLit h) + +closure :: ( IsExpr e + , KnownRepr TypeRepr tp + , KnownRepr TypeRepr ret + , KnownCtx TypeRepr args + ) + => e (FunctionHandleType (args::>tp) ret) + -> e tp + -> e (FunctionHandleType args ret) +closure h a = app (Closure knownRepr knownRepr h knownRepr a) + + +---------------------------------------------------------------------- +-- IdentValueMap + +-- | Initialize the ident value map to the given value. +emptyIdentValueMap :: KnownRepr TypeRepr tp => IsExpr e => e (StringMapType tp) +emptyIdentValueMap = app (EmptyStringMap knownRepr) + +-- Update the value of the ident value map with the given value. +setIdentValue :: (IsExpr e, KnownRepr TypeRepr tp) + => e (StringMapType tp) + -> Text + -> e (MaybeType tp) + -> e (StringMapType tp) +setIdentValue m i v = app (InsertStringMapEntry knownRepr m (litExpr i) v) + +----------------------------------------------------------------------- +-- Struct + +mkStruct :: IsExpr e + => CtxRepr ctx + -> Ctx.Assignment e ctx + -> e (StructType ctx) +mkStruct tps asgn = app (MkStruct tps asgn) + +getStruct :: (IsExpr e) + => Ctx.Index ctx tp + -> e (StructType ctx) + -> e tp +getStruct i s + | Just (MkStruct _ asgn) <- asApp s = asgn Ctx.! i + | Just (SetStruct _ s' i' x) <- asApp s = + case testEquality i i' of + Just Refl -> x + Nothing -> getStruct i s' + | otherwise = + case exprType s of + StructRepr tps -> app (GetStruct s i (tps Ctx.! i)) + +setStruct :: IsExpr e + => CtxRepr ctx + -> e (StructType ctx) + -> Ctx.Index ctx tp + -> e tp + -> e (StructType ctx) +setStruct tps s i x + | Just (MkStruct _ asgn) <- asApp s = app (MkStruct tps (asgn & ixF i .~ x)) + | otherwise = app (SetStruct tps s i x) + + + +------------------------------------------------------- +-- Multibyte operations + +bigEndianStore + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to write + -> expr (BVType addrWidth) + -> expr (BVType valWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) +bigEndianStore addrWidth cellWidth valWidth num basePtr v wordMap = go num + where go 0 = wordMap + go n + | Just (Some idx) <- someNat $ (fromIntegral (num-n)) * (intValue cellWidth) + , Just LeqProof <- testLeq (addNat idx cellWidth) valWidth + = app $ InsertWordMap addrWidth (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr (app $ BVLit addrWidth (BV.mkBV addrWidth (toInteger (n-1))))) + (app $ BVSelect idx cellWidth valWidth v) + (go (n-1)) + go _ = error "bad size parameters in bigEndianStore!" + +littleEndianStore + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to write + -> expr (BVType addrWidth) + -> expr (BVType valWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) +littleEndianStore addrWidth cellWidth valWidth num basePtr v wordMap = go num + where go 0 = wordMap + go n + | Just (Some idx) <- someNat $ (fromIntegral (n-1)) * (intValue cellWidth) + , Just LeqProof <- testLeq (addNat idx cellWidth) valWidth + = app $ InsertWordMap addrWidth (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr (app $ BVLit addrWidth (BV.mkBV addrWidth (toInteger (n-1))))) + (app $ BVSelect idx cellWidth valWidth v) + (go (n-1)) + go _ = error "bad size parameters in littleEndianStore!" + +concatExprs :: forall w a expr + . (IsExpr expr, 1 <= w) + => NatRepr w + -> [expr (BVType w)] + -> (forall w'. (1 <= w') => NatRepr w' -> expr (BVType w') -> a) + -> a + +concatExprs _ [] = \_ -> error "Cannot concatenate 0 elements together" +concatExprs w (a:as) = go a as + + where go :: (1 <= w) + => expr (BVType w) + -> [expr (BVType w)] + -> (forall w'. (1 <= w') => NatRepr w' -> expr (BVType w') -> a) + -> a + go x0 [] k = k w x0 + go x0 (x:xs) k = go x xs (\(w'::NatRepr w') z -> + withLeqProof (leqAdd LeqProof w' :: LeqProof 1 (w+w')) + (k (addNat w w') (app $ BVConcat w w' x0 z))) + +bigEndianLoad + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to load + -> expr (BVType addrWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (BVType valWidth) +bigEndianLoad addrWidth cellWidth valWidth num basePtr wordMap = + let segs = [ app $ LookupWordMap (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr + (app $ BVLit addrWidth i)) + wordMap + | i <- BV.enumFromToUnsigned (BV.zero addrWidth) (BV.mkBV addrWidth (toInteger (num-1))) + ] in + concatExprs cellWidth segs $ \w x -> + case testEquality w valWidth of + Just Refl -> x + Nothing -> error "bad size parameters in bigEndianLoad!" + + +bigEndianLoadDef + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to load + -> expr (BVType addrWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (BVType cellWidth) + -> expr (BVType valWidth) +bigEndianLoadDef addrWidth cellWidth valWidth num basePtr wordMap defVal = + let segs = [ app $ LookupWordMapWithDefault (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr + (app $ BVLit addrWidth i)) + wordMap + defVal + | i <- BV.enumFromToUnsigned (BV.zero addrWidth) (BV.mkBV addrWidth (toInteger (num-1))) + ] in + concatExprs cellWidth segs $ \w x -> + case testEquality w valWidth of + Just Refl -> x + Nothing -> error "bad size parameters in bigEndianLoadDef!" + +littleEndianLoad + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to load + -> expr (BVType addrWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (BVType valWidth) +littleEndianLoad addrWidth cellWidth valWidth num basePtr wordMap = + let segs = [ app $ LookupWordMap (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr + (app $ BVLit addrWidth i)) + wordMap + | i <- reverse $ BV.enumFromToUnsigned (BV.zero addrWidth) (BV.mkBV addrWidth (toInteger (num-1))) + ] in + concatExprs cellWidth segs $ \w x -> + case testEquality w valWidth of + Just Refl -> x + Nothing -> error "bad size parameters in littleEndianLoad!" + +littleEndianLoadDef + :: (IsExpr expr, 1 <= addrWidth, 1 <= valWidth, 1 <= cellWidth) + => NatRepr addrWidth + -> NatRepr cellWidth + -> NatRepr valWidth + -> Int -- ^ number of bytes to load + -> expr (BVType addrWidth) + -> expr (WordMapType addrWidth (BaseBVType cellWidth)) + -> expr (BVType cellWidth) + -> expr (BVType valWidth) +littleEndianLoadDef addrWidth cellWidth valWidth num basePtr wordMap defVal = + let segs = [ app $ LookupWordMapWithDefault (BaseBVRepr cellWidth) + (app $ BVAdd addrWidth basePtr + (app $ BVLit addrWidth i)) + wordMap + defVal + | i <- reverse $ BV.enumFromToUnsigned (BV.zero addrWidth) (BV.mkBV addrWidth (toInteger (num-1))) + ] in + concatExprs cellWidth segs $ \w x -> + case testEquality w valWidth of + Just Refl -> x + Nothing -> error "bad size parameters in littleEndianLoadDef!" diff --git a/src/Lang/Crucible/Types.hs b/src/Lang/Crucible/Types.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Types.hs @@ -0,0 +1,505 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Types +-- Description : This module exports the types used in Crucible +-- expressions. +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module exports the types used in Crucible expressions. +-- +-- These types are largely used as indexes to various GADTs and type +-- families as a way to let the GHC typechecker help us keep expressions +-- of the embedded CFG language apart. +-- +-- In addition, we provide a value-level reification of the type +-- indices that can be examined by pattern matching, called 'TypeRepr'. +-- The 'KnownRepr' class computes the value-level representation +-- of a given type index, when the type is known at compile time. +-- Similar setups exist for other components of the type system: +-- bitvector data and type contexts. +------------------------------------------------------------------------ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +module Lang.Crucible.Types + ( -- * CrucibleType data kind + type CrucibleType + -- ** Constructors for kind CrucibleType + , AnyType + , UnitType + , BoolType + , NatType + , IntegerType + , RealValType + , SymbolicStructType + , ComplexRealType + , BVType + , FloatType + , IEEEFloatType + , CharType + , StringType + , FunctionHandleType + , MaybeType + , RecursiveType + , IntrinsicType + , VectorType + , SequenceType + , StructType + , VariantType + , ReferenceType + , WordMapType + + , StringMapType + , SymbolicArrayType + + -- * IsRecursiveType + , IsRecursiveType(..) + + -- * Base type injection + , BaseToType + , baseToType + + , AsBaseType(..) + , asBaseType + + -- * Other stuff + , CtxRepr + , pattern KnownBV + + -- * Representation of Crucible types + , TypeRepr(..) + + -- * Re-exports + , module Data.Parameterized.Ctx + , module Data.Parameterized.NatRepr + , module Data.Parameterized.SymbolRepr + , module What4.BaseTypes + , FloatInfo + , HalfFloat + , SingleFloat + , DoubleFloat + , QuadFloat + , X86_80Float + , DoubleDoubleFloat + , FloatInfoRepr(..) + , FloatInfoToBitWidth + , floatInfoToBVTypeRepr + ) where + +import Data.Hashable +import Data.Type.Equality +import GHC.TypeNats (Nat, KnownNat) +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Ctx +import Data.Parameterized.NatRepr +import Data.Parameterized.SymbolRepr +import qualified Data.Parameterized.TH.GADT as U +import Prettyprinter + +import What4.BaseTypes +import What4.InterpretedFloatingPoint + +------------------------------------------------------------------------ +-- Crucible types + + +-- | This typeclass is used to register recursive Crucible types +-- with the compiler. This class defines, for a given symbol, +-- both the type-level and the representative-level unrolling +-- of a named recursive type. +-- +-- The symbol constitutes a unique compile-time identifier for the +-- recursive type, allowing recursive types to be unrolled at run +-- time without requiring dynamic checks. +-- +-- Parameter @nm@ has kind 'Symbol'. +class IsRecursiveType (nm::Symbol) where + type UnrollType nm (ctx :: Ctx CrucibleType) :: CrucibleType + unrollType :: SymbolRepr nm -> CtxRepr ctx -> TypeRepr (UnrollType nm ctx) + +type CtxRepr = Ctx.Assignment TypeRepr + +-- | This data kind describes the types of values and expressions that +-- can occur in Crucible CFGs. +data CrucibleType where + -- | An injection of solver interface types into Crucible types + BaseToType :: BaseType -> CrucibleType + + -- | A dynamic type that can contain values of any type. + AnyType :: CrucibleType + + -- | A type containing a single value "Unit" + UnitType :: CrucibleType + + -- | A type for natural numbers. + NatType :: CrucibleType + + -- | A type index for floating point numbers, whose interpretation + -- depends on the symbolic backend. + FloatType :: FloatInfo -> CrucibleType + -- | A single character, as a 16-bit wide char. + CharType :: CrucibleType + -- | A function handle taking a context of formal arguments and a return type + FunctionHandleType :: Ctx CrucibleType -> CrucibleType -> CrucibleType + + -- The Maybe type lifted into crucible expressions + MaybeType :: CrucibleType -> CrucibleType + + -- A finite (one-dimensional) sequence of values. Vectors are + -- optimized for random-access indexing and updating. Vectors + -- of different lengths may not be combined at join points. + VectorType :: CrucibleType -> CrucibleType + + -- Sequences of values, represented as linked lists of cons cells. Sequences + -- only allow access to the front. Unlike Vectors, sequences of + -- different lengths may be combined at join points. + SequenceType :: CrucibleType -> CrucibleType + + -- A structure is an aggregate type consisting of a sequence of values. + -- The type of each value is known statically. + StructType :: Ctx CrucibleType -> CrucibleType + + -- The type of mutable reference cells. + ReferenceType :: CrucibleType -> CrucibleType + + -- A variant is a disjoint union of the types listed in the context. + VariantType :: Ctx CrucibleType -> CrucibleType + + -- A finite map from bitvector values to the given crucible type. + -- The nat index gives the width of the bitvector values used to index + -- the map. + WordMapType :: Nat -> BaseType -> CrucibleType + + -- Named recursive types, named by the given symbol. To use recursive types + -- you must provide an instance of the IsRecursiveType class that gives + -- the unfolding of this recursive type. The RollRecursive and UnrollRecursive + -- operations witness the isomorphism between a recursive type and its one-step + -- unrolling. Similar to Haskell's newtype, recursive types do not necessarily + -- have to mention the recursive type being defined; in which case, the type + -- is simply a new named type which is isomorphic to its definition. + RecursiveType :: Symbol -> Ctx CrucibleType -> CrucibleType + + -- Named intrinsic types. Intrinsic types are a way to extend the + -- crucible type system after-the-fact and add new type + -- implementations. Core crucible provides no operations on + -- intrinsic types; they must be provided as built-in override + -- functions, or via the language extension mechanism. See the + -- `IntrinsicClass` typeclass and the `Intrinsic` type family + -- defined in "Lang.Crucible.Simulator.Intrinsics". + -- + -- The context of crucible types are type arguments to the intrinsic type. + IntrinsicType :: Symbol -> Ctx CrucibleType -> CrucibleType + + -- A partial map from strings to values. + StringMapType :: CrucibleType -> CrucibleType + +type BaseToType = 'BaseToType -- ^ @:: 'BaseType' -> 'CrucibleType'@. +type BoolType = BaseToType BaseBoolType -- ^ @:: 'CrucibleType'@. +type BVType w = BaseToType (BaseBVType w) -- ^ @:: 'Nat' -> 'CrucibleType'@. +type ComplexRealType = BaseToType BaseComplexType -- ^ @:: 'CrucibleType'@. +type IntegerType = BaseToType BaseIntegerType -- ^ @:: 'CrucibleType'@. +type StringType si = BaseToType (BaseStringType si) -- ^ @:: 'StringInfo' -> 'CrucibleType'@. +type RealValType = BaseToType BaseRealType -- ^ @:: 'CrucibleType'@. +type IEEEFloatType p = BaseToType (BaseFloatType p) -- ^ @:: FloatPrecision -> CrucibleType@ + +type SymbolicArrayType idx xs = BaseToType (BaseArrayType idx xs) -- ^ @:: 'Ctx.Ctx' 'BaseType' -> 'BaseType' -> 'CrucibleType'@. +type SymbolicStructType flds = BaseToType (BaseStructType flds) -- ^ @:: 'Ctx.Ctx' 'BaseType' -> 'CrucibleType'@. + + +-- | A dynamic type that can contain values of any type. +type AnyType = 'AnyType -- ^ @:: 'CrucibleType'@. + +-- | A single character, as a 16-bit wide char. +type CharType = 'CharType -- ^ @:: 'CrucibleType'@. + +-- | A type index for floating point numbers, whose interpretation +-- depends on the symbolic backend. +type FloatType = 'FloatType -- ^ @:: 'FloatInfo' -> 'CrucibleType'@. + + +-- | A function handle taking a context of formal arguments and a return type. +type FunctionHandleType = 'FunctionHandleType -- ^ @:: 'Ctx' 'CrucibleType' -> 'CrucibleType' -> 'CrucibleType'@. + +-- | Named recursive types, named by the given symbol. To use +-- recursive types you must provide an instance of the +-- 'IsRecursiveType' class that gives the unfolding of this recursive +-- type. The 'Lang.Crucible.CFG.Expr.RollRecursive' and +-- 'Lang.Crucible.CFG.Expr.UnrollRecursive' operations witness the +-- isomorphism between a recursive type and its one-step unrolling. +-- Similar to Haskell's @newtype@, recursive types do not necessarily +-- have to mention the recursive type being defined; in which case, +-- the type is simply a new named type which is isomorphic to its +-- definition. +type RecursiveType = 'RecursiveType -- ^ @:: 'Symbol' -> 'Ctx' 'CrucibleType' -> 'CrucibleType'@. + +-- | Named intrinsic types. Intrinsic types are a way to extend the +-- Crucible type system after-the-fact and add new type +-- implementations. Core Crucible provides no operations on intrinsic +-- types; they must be provided as built-in override functions. See +-- the 'Lang.Crucible.Simulator.Intrinsics.IntrinsicClass' typeclass +-- and the 'Lang.Crucible.Simulator.Intrinsics.Intrinsic' type family +-- defined in "Lang.Crucible.Simulator.Intrinsics". +type IntrinsicType ctx = 'IntrinsicType ctx -- ^ @:: 'Symbol' -> 'Ctx' 'CrucibleType' -> 'CrucibleType'@. + +-- | The type of mutable reference cells. +type ReferenceType = 'ReferenceType -- ^ @:: 'CrucibleType' -> 'CrucibleType'@. + +-- | The 'Maybe' type lifted into Crucible expressions. +type MaybeType = 'MaybeType -- ^ @:: 'CrucibleType' -> 'CrucibleType'@. + +-- | A partial map from strings to values. +type StringMapType = 'StringMapType -- ^ @:: 'CrucibleType' -> 'CrucibleType'@. + +-- | A structure is an aggregate type consisting of a sequence of +-- values. The type of each value is known statically. +type StructType = 'StructType -- ^ @:: 'Ctx' 'CrucibleType' -> 'CrucibleType'@. + +-- | A type containing a single value "Unit". +type UnitType = 'UnitType -- ^ @:: 'CrucibleType'@. + +-- | A type for natural numbers. +type NatType = 'NatType -- ^ @:: 'CrucibleType'@. + +-- | A variant is a disjoint union of the types listed in the context. +type VariantType = 'VariantType -- ^ @:: 'Ctx' 'CrucibleType' -> 'CrucibleType'@. + +-- | A finite (one-dimensional) sequence of values. Vectors are +-- optimized for random-access indexing and updating. Vectors +-- of different lengths may not be combined at join points. +type VectorType = 'VectorType -- ^ @:: 'CrucibleType' -> 'CrucibleType'@. + +-- | Sequences of values, represented as linked lists of cons cells. Sequences +-- only allow access to the front. Unlike Vectors, sequences of +-- different lengths may be combined at join points. +type SequenceType = 'SequenceType -- ^ @:: 'CrucibleType' -> 'CrucibleType'@. + +-- | A finite map from bitvector values to the given Crucible type. +-- The 'Nat' index gives the width of the bitvector values used to +-- index the map. +type WordMapType = 'WordMapType -- ^ @:: 'Nat' -> 'BaseType' -> 'CrucibleType'@. + +---------------------------------------------------------------- +-- Base Type Injection + +baseToType :: BaseTypeRepr bt -> TypeRepr (BaseToType bt) +baseToType bt = + case bt of + BaseBoolRepr -> BoolRepr + BaseIntegerRepr -> IntegerRepr + BaseRealRepr -> RealValRepr + BaseStringRepr si -> StringRepr si + BaseBVRepr w -> BVRepr w + BaseComplexRepr -> ComplexRealRepr + BaseArrayRepr idx xs -> SymbolicArrayRepr idx xs + BaseStructRepr flds -> SymbolicStructRepr flds + BaseFloatRepr ps -> IEEEFloatRepr ps + +data AsBaseType tp where + AsBaseType :: tp ~ BaseToType bt => BaseTypeRepr bt -> AsBaseType tp + NotBaseType :: AsBaseType tp + +asBaseType :: TypeRepr tp -> AsBaseType tp +asBaseType tp = + case tp of + BoolRepr -> AsBaseType BaseBoolRepr + IntegerRepr -> AsBaseType BaseIntegerRepr + RealValRepr -> AsBaseType BaseRealRepr + StringRepr si -> AsBaseType (BaseStringRepr si) + BVRepr w -> AsBaseType (BaseBVRepr w) + ComplexRealRepr -> AsBaseType BaseComplexRepr + SymbolicArrayRepr idx xs -> + AsBaseType (BaseArrayRepr idx xs) + IEEEFloatRepr ps -> + AsBaseType (BaseFloatRepr ps) + SymbolicStructRepr flds -> AsBaseType (BaseStructRepr flds) + _ -> NotBaseType + +---------------------------------------------------------------- +-- Type representatives + +-- | A family of representatives for Crucible types. Parameter @tp@ +-- has kind 'CrucibleType'. +data TypeRepr (tp::CrucibleType) where + AnyRepr :: TypeRepr AnyType + UnitRepr :: TypeRepr UnitType + BoolRepr :: TypeRepr BoolType + NatRepr :: TypeRepr NatType + IntegerRepr :: TypeRepr IntegerType + RealValRepr :: TypeRepr RealValType + ComplexRealRepr :: TypeRepr ComplexRealType + BVRepr :: (1 <= n) => !(NatRepr n) -> TypeRepr (BVType n) + IntrinsicRepr :: !(SymbolRepr nm) + -> !(CtxRepr ctx) + -> TypeRepr (IntrinsicType nm ctx) + RecursiveRepr :: IsRecursiveType nm + => SymbolRepr nm + -> CtxRepr ctx + -> TypeRepr (RecursiveType nm ctx) + + -- | This is a representation of floats that works at known fixed + -- mantissa and exponent widths, but the symbolic backend may pick + -- the representation. + FloatRepr :: !(FloatInfoRepr flt) -> TypeRepr (FloatType flt) + + -- | This is a float with user-definable mantissa and exponent that + -- maps directly to the what4 base type. + IEEEFloatRepr :: !(FloatPrecisionRepr ps) -> TypeRepr (IEEEFloatType ps) + + CharRepr :: TypeRepr CharType + StringRepr :: StringInfoRepr si -> TypeRepr (StringType si) + FunctionHandleRepr :: !(CtxRepr ctx) + -> !(TypeRepr ret) + -> TypeRepr (FunctionHandleType ctx ret) + + MaybeRepr :: !(TypeRepr tp) -> TypeRepr (MaybeType tp) + SequenceRepr:: !(TypeRepr tp) -> TypeRepr (SequenceType tp) + VectorRepr :: !(TypeRepr tp) -> TypeRepr (VectorType tp) + StructRepr :: !(CtxRepr ctx) -> TypeRepr (StructType ctx) + VariantRepr :: !(CtxRepr ctx) -> TypeRepr (VariantType ctx) + ReferenceRepr :: !(TypeRepr a) -> TypeRepr (ReferenceType a) + + WordMapRepr :: (1 <= n) + => !(NatRepr n) + -> !(BaseTypeRepr tp) + -> TypeRepr (WordMapType n tp) + + StringMapRepr :: !(TypeRepr tp) -> TypeRepr (StringMapType tp) + + SymbolicArrayRepr :: !(Ctx.Assignment BaseTypeRepr (idx::>tp)) + -> !(BaseTypeRepr t) + -> TypeRepr (SymbolicArrayType (idx::>tp) t) + + -- A reference to a symbolic struct. + SymbolicStructRepr :: Ctx.Assignment BaseTypeRepr ctx + -> TypeRepr (SymbolicStructType ctx) + +------------------------------------------------------------------------------ +-- Representable class instances + +instance KnownRepr TypeRepr AnyType where knownRepr = AnyRepr +instance KnownRepr TypeRepr UnitType where knownRepr = UnitRepr +instance KnownRepr TypeRepr CharType where knownRepr = CharRepr +instance KnownRepr TypeRepr NatType where knownRepr = NatRepr + +instance KnownRepr BaseTypeRepr bt => KnownRepr TypeRepr (BaseToType bt) where + knownRepr = baseToType knownRepr + +instance KnownCtx TypeRepr ctx => KnownRepr TypeRepr (StructType ctx) where + knownRepr = StructRepr knownRepr + +instance KnownCtx TypeRepr ctx => KnownRepr TypeRepr (VariantType ctx) where + knownRepr = VariantRepr knownRepr + +instance KnownRepr TypeRepr a => KnownRepr TypeRepr (ReferenceType a) where + knownRepr = ReferenceRepr knownRepr + +instance (KnownSymbol s, KnownCtx TypeRepr ctx) => KnownRepr TypeRepr (IntrinsicType s ctx) where + knownRepr = IntrinsicRepr knownSymbol knownRepr + +instance (KnownSymbol s, KnownCtx TypeRepr ctx, IsRecursiveType s) => KnownRepr TypeRepr (RecursiveType s ctx) where + knownRepr = RecursiveRepr knownSymbol knownRepr + +instance (1 <= w, KnownNat w, KnownRepr BaseTypeRepr tp) + => KnownRepr TypeRepr (WordMapType w tp) where + knownRepr = WordMapRepr (knownNat :: NatRepr w) (knownRepr :: BaseTypeRepr tp) + +instance (KnownCtx TypeRepr ctx, KnownRepr TypeRepr ret) + => KnownRepr TypeRepr (FunctionHandleType ctx ret) where + knownRepr = FunctionHandleRepr knownRepr knownRepr + +instance KnownRepr FloatInfoRepr flt => KnownRepr TypeRepr (FloatType flt) where + knownRepr = FloatRepr knownRepr + +instance KnownRepr FloatPrecisionRepr ps => KnownRepr TypeRepr (IEEEFloatType ps) where + knownRepr = IEEEFloatRepr knownRepr + +instance KnownRepr TypeRepr tp => KnownRepr TypeRepr (VectorType tp) where + knownRepr = VectorRepr knownRepr + +instance KnownRepr TypeRepr tp => KnownRepr TypeRepr (SequenceType tp) where + knownRepr = SequenceRepr knownRepr + +instance KnownRepr TypeRepr tp => KnownRepr TypeRepr (MaybeType tp) where + knownRepr = MaybeRepr knownRepr + +instance KnownRepr TypeRepr tp => KnownRepr TypeRepr (StringMapType tp) where + knownRepr = StringMapRepr knownRepr + +-- | Pattern synonym specifying bitvector TypeReprs. Intended to be use +-- with type applications, e.g., @KnownBV \@32@. +pattern KnownBV :: forall n. (1 <= n, KnownNat n) => TypeRepr (BVType n) +pattern KnownBV <- BVRepr (testEquality (knownRepr :: NatRepr n) -> Just Refl) + where KnownBV = knownRepr + +------------------------------------------------------------------------ +-- Misc typeclass instances + +-- Force TypeRepr, etc. to be in context for next slice. +$(return []) + +instance HashableF TypeRepr where + hashWithSaltF = hashWithSalt +instance Hashable (TypeRepr ty) where + hashWithSalt = $(U.structuralHashWithSalt [t|TypeRepr|] []) + +instance Pretty (TypeRepr tp) where + pretty = viaShow + +instance Show (TypeRepr tp) where + showsPrec = $(U.structuralShowsPrec [t|TypeRepr|]) +instance ShowF TypeRepr + + +instance TestEquality TypeRepr where + testEquality = $(U.structuralTypeEquality [t|TypeRepr|] + [ (U.TypeApp (U.ConType [t|NatRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|SymbolRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|FloatInfoRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|FloatPrecisionRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|CtxRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|BaseTypeRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|StringInfoRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.ConType [t|TypeRepr|]) U.AnyType, [|testEquality|]) + , (U.TypeApp (U.TypeApp (U.ConType [t|Ctx.Assignment|]) U.AnyType) U.AnyType + , [|testEquality|]) + ] + ) +instance Eq (TypeRepr tp) where + x == y = isJust (testEquality x y) + +instance OrdF TypeRepr where + compareF = $(U.structuralTypeOrd [t|TypeRepr|] + [ (U.TypeApp (U.ConType [t|NatRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|SymbolRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|FloatInfoRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|FloatPrecisionRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|BaseTypeRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|StringInfoRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|TypeRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.ConType [t|CtxRepr|]) U.AnyType, [|compareF|]) + , (U.TypeApp (U.TypeApp (U.ConType [t|Ctx.Assignment|]) U.AnyType) U.AnyType + , [|compareF|]) + ] + ) diff --git a/src/Lang/Crucible/Utils/BitSet.hs b/src/Lang/Crucible/Utils/BitSet.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/BitSet.hs @@ -0,0 +1,109 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Utils.BitSet +-- Description : Encode a set of enumerable elements using the bit-positions +-- in an Integer +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides a simple bitset datastructure +-- built on top of GHC-native Integers. +------------------------------------------------------------------------ +module Lang.Crucible.Utils.BitSet +( BitSet +, getBits +, empty +, null +, singleton +, insert +, remove +, size +, member +, isSubsetOf +, difference +, intersection +, union +, toList +, foldr +, foldl +, foldl' +) where + +import Data.Bits +import Data.Word +import Data.Hashable +import qualified Data.List as List +import Prelude hiding (null, foldr, foldl) + +newtype BitSet a = BitSet { getBits :: Integer } + deriving (Show, Eq, Ord) + +instance Hashable (BitSet a) where + hashWithSalt s (BitSet x) = hashWithSalt s x + +empty :: BitSet a +empty = BitSet zeroBits + +null :: BitSet a -> Bool +null = (0==) . getBits + +singleton :: Enum a => a -> BitSet a +singleton a = BitSet (bit (fromEnum a)) + +insert :: Enum a => a -> BitSet a -> BitSet a +insert a (BitSet x) = BitSet (setBit x (fromEnum a)) + +remove :: Enum a => a -> BitSet a -> BitSet a +remove a (BitSet x) = BitSet (clearBit x (fromEnum a)) + +union :: BitSet a -> BitSet a -> BitSet a +union (BitSet x) (BitSet y) = BitSet (x .|. y) + +intersection :: BitSet a -> BitSet a -> BitSet a +intersection (BitSet x) (BitSet y) = BitSet (x .&. y) + +difference :: BitSet a -> BitSet a -> BitSet a +difference (BitSet x) (BitSet y) = BitSet (x .&. complement y) + +isSubsetOf :: BitSet a -> BitSet a -> Bool +isSubsetOf (BitSet x) (BitSet y) = x .|. y == y + +member :: Enum a => a -> BitSet a -> Bool +member a (BitSet x) = testBit x (fromEnum a) + +size :: BitSet a -> Int +size (BitSet x) = popCount x + +toList :: Enum a => BitSet a -> [a] +toList (BitSet bs) = go bs 0 + where go :: Enum a => Integer -> Int -> [a] + go 0 _ = [] + go x i + | y .&. 0xffffffff == 0 = go (shiftR x 32) $! (i+32) + | y .&. 0x0000ffff == 0 = go (shiftR x 16) $! (i+16) + | y .&. 0x000000ff == 0 = go (shiftR x 8) $! (i+ 8) + | otherwise = concat + [ if testBit y 0 then [toEnum (i+0)] else [] + , if testBit y 1 then [toEnum (i+1)] else [] + , if testBit y 2 then [toEnum (i+2)] else [] + , if testBit y 3 then [toEnum (i+3)] else [] + , if testBit y 4 then [toEnum (i+4)] else [] + , if testBit y 5 then [toEnum (i+5)] else [] + , if testBit y 6 then [toEnum (i+6)] else [] + , if testBit y 7 then [toEnum (i+7)] else [] + , go (shiftR x 8) $! (i+8) + ] + + where y :: Word32 + y = fromInteger x + +foldl' :: Enum a => (b -> a -> b) -> b -> BitSet a -> b +foldl' f z = List.foldl' f z . toList + +foldl :: Enum a => (b -> a -> b) -> b -> BitSet a -> b +foldl f z = List.foldl f z . toList + +foldr :: Enum a => (a -> b -> b) -> b -> BitSet a -> b +foldr f z = List.foldr f z . toList diff --git a/src/Lang/Crucible/Utils/CoreRewrite.hs b/src/Lang/Crucible/Utils/CoreRewrite.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/CoreRewrite.hs @@ -0,0 +1,132 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Utils.CoreRewrite +-- Description : Operations for manipulating Core CFGs +-- Copyright : (c) Galois, Inc 2016 +-- License : BSD3 +-- Maintainer : Simon Winwood +-- Stability : provisional +-- +------------------------------------------------------------------------ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} + +module Lang.Crucible.Utils.CoreRewrite +( annotateCFGStmts +) where + +import Control.Lens + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Map (Pair(..)) +import Data.Parameterized.TraversableFC + +import Lang.Crucible.CFG.Core +import Lang.Crucible.CFG.Extension + +------------------------------------------------------------------------ +-- CFG annotation + + +-- | This function walks through all the blocks in the CFG calling +-- @fS@ on each @Stmt@ and @fT@ on each @TermStmt@. These functions +-- return a possible annotaition statement (which has access to the +-- result of the statement, if any) along with a context diff which +-- describes any new variables. +annotateCFGStmts :: + TraverseExt ext => + (forall cin cout. Some (BlockID blocks) -> Ctx.Size cout -> Stmt ext cin cout -> Maybe (StmtSeq ext blocks UnitType cout)) + -- ^ This is the annotation function. The resulting @StmtSeq@ gets + -- spliced in after the statement so that they can inspect the + -- result if desired. The terminal statement is ignored. + -> (forall ctx'. Some (BlockID blocks) -> Ctx.Size ctx' -> TermStmt blocks ret ctx' -> Maybe (StmtSeq ext blocks UnitType ctx')) + -- ^ As above but for the final term stmt, where the annotation will + -- be _before_ the term stmt. + -> CFG ext blocks ctx ret -> CFG ext blocks ctx ret +annotateCFGStmts fS fT = mapCFGBlocks (annotateBlockStmts fS fT) + +mapCFGBlocks :: (forall x. Block ext blocks ret x -> Block ext blocks ret x) + -> CFG ext blocks ctx ret -> CFG ext blocks ctx ret +mapCFGBlocks f cfg = cfg { cfgBlockMap = fmapFC f (cfgBlockMap cfg) } + +annotateBlockStmts :: + forall ext blocks ret ctx. + TraverseExt ext => + (forall cin cout. Some (BlockID blocks) -> Ctx.Size cout -> Stmt ext cin cout -> Maybe (StmtSeq ext blocks UnitType cout)) + -- ^ This is the annotation function. Annotation statements go + -- after the statement so that they can inspect the result if + -- desired. We use Diff here over CtxEmbedding as the remainder of + -- the statements can't use the result of the annotation function + -> (forall ctx'. Some (BlockID blocks) -> Ctx.Size ctx' -> TermStmt blocks ret ctx' -> Maybe (StmtSeq ext blocks UnitType ctx')) + -- ^ As above but for the final term stmt, where the annotation will + -- be _before_ the term stmt. + -> Block ext blocks ret ctx + -> Block ext blocks ret ctx +annotateBlockStmts fS fT b = b & blockStmts %~ goStmts initialCtxe + where + initialCtxe = Ctx.identityEmbedding (Ctx.size (blockInputs b)) + goStmts :: forall ctx' ctx''. Ctx.CtxEmbedding ctx' ctx'' + -> StmtSeq ext blocks ret ctx' -> StmtSeq ext blocks ret ctx'' + goStmts ctxe (ConsStmt loc stmt rest) = + case applyEmbeddingStmt ctxe stmt of + Pair stmt' ctxe' -> + case fS (Some $ blockID b) (ctxe' ^. Ctx.ctxeSize) stmt' of + Nothing -> ConsStmt loc stmt' (goStmts ctxe' rest) + Just annotSeq -> + ConsStmt loc stmt' (appendStmtSeq ctxe' annotSeq (flip goStmts rest)) + goStmts ctxe (TermStmt loc term) = + let term' = Ctx.applyEmbedding ctxe term in + case fT (Some $ blockID b) (ctxe ^. Ctx.ctxeSize) term' of + Nothing -> TermStmt loc term' + Just annotSeq -> + -- FIXME: we could use extendContext here instead + let restf :: forall fctx. Ctx.CtxEmbedding ctx' fctx -> StmtSeq ext blocks ret fctx + restf ctxe'' = TermStmt loc (Ctx.applyEmbedding ctxe'' term) + in appendStmtSeq ctxe annotSeq restf + +stmtDiff :: Stmt ext ctx ctx' -> Ctx.Diff ctx ctx' +stmtDiff stmt = + case stmt of + SetReg {} -> Ctx.knownDiff + ExtendAssign{} -> Ctx.knownDiff + CallHandle {} -> Ctx.knownDiff + Print {} -> Ctx.knownDiff + ReadGlobal {} -> Ctx.knownDiff + WriteGlobal {} -> Ctx.knownDiff + FreshConstant{} -> Ctx.knownDiff + FreshFloat{} -> Ctx.knownDiff + FreshNat{} -> Ctx.knownDiff + NewRefCell {} -> Ctx.knownDiff + NewEmptyRefCell{}-> Ctx.knownDiff + ReadRefCell {} -> Ctx.knownDiff + WriteRefCell {} -> Ctx.knownDiff + DropRefCell {} -> Ctx.knownDiff + Assert {} -> Ctx.knownDiff + Assume {} -> Ctx.knownDiff + +-- | This appends two @StmtSeq@, throwing away the @TermStmt@ from the first @StmtSeq@ +-- It could probably be generalized to @Ctx.Diff@ instead of an embedding. +appendStmtSeq :: forall ext blocks ret ret' ctx ctx'. + Ctx.CtxEmbedding ctx ctx' + -> StmtSeq ext blocks ret ctx' + -> (forall ctx''. Ctx.CtxEmbedding ctx ctx'' -> StmtSeq ext blocks ret' ctx'') + -> StmtSeq ext blocks ret' ctx' +appendStmtSeq ctxe seq1 seq2f = go ctxe seq1 + where + go :: forall ctx''. + Ctx.CtxEmbedding ctx ctx'' + -> StmtSeq ext blocks ret ctx'' + -> StmtSeq ext blocks ret' ctx'' + go ctxe' (ConsStmt loc stmt rest) = + -- This just throws away the new variables, which is OK as seq2 + -- can't reference them. + let ctxe'' = Ctx.extendEmbeddingRightDiff (stmtDiff stmt) ctxe' + in ConsStmt loc stmt (go ctxe'' rest) + go ctxe' (TermStmt _loc _term) = seq2f ctxe' diff --git a/src/Lang/Crucible/Utils/MonadVerbosity.hs b/src/Lang/Crucible/Utils/MonadVerbosity.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/MonadVerbosity.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} + +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Utils.MonadVerbosity +-- Description : A typeclass for monads equipped with a logging function +-- Copyright : (c) Galois, Inc 2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +module Lang.Crucible.Utils.MonadVerbosity + ( MonadVerbosity(..) + , withVerbosity + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import System.IO + +-- | This class applies to monads that contain verbosity information, +-- which is used to control the level of debugging messages +-- presented to the user. +class (Applicative m, MonadIO m) => MonadVerbosity m where + getVerbosity :: m Int + + whenVerbosity :: (Int -> Bool) -> m () -> m () + whenVerbosity p m = do + v <- getVerbosity + when (p v) m + + getLogFunction :: m (Int -> String -> IO ()) + + -- Get function for writing a line of output. + getLogLnFunction :: m (Int -> String -> IO ()) + getLogLnFunction = do + w <- getLogFunction + return (\n s -> w n (s ++ "\n")) + + -- | Print a message. + showWarning :: String -> m () + + -- | Print a warning message when verbosity satisfies predicate. + showWarningWhen :: (Int -> Bool) -> String -> m () + showWarningWhen p m = whenVerbosity p $ showWarning m + + +instance (Applicative m, MonadIO m) => MonadVerbosity (ReaderT (Handle, Int) m) where + getVerbosity = snd <$> ask + getLogFunction = do + (h,v) <- ask + return $ \n msg -> do + when (n < v) $ liftIO $ hPutStr h msg + showWarning msg = do + (h, _) <- ask + liftIO $ hPutStrLn h msg + +withVerbosity :: Handle + -> Int + -> (forall m. MonadVerbosity m => m a) + -> IO a +withVerbosity h v f = runReaderT f (h,v) diff --git a/src/Lang/Crucible/Utils/MuxTree.hs b/src/Lang/Crucible/Utils/MuxTree.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/MuxTree.hs @@ -0,0 +1,258 @@ +{-| +Module : Lang.Crucible.Utils.MuxTree +Copyright : (c) Galois, Inc 2018 +License : BSD3 +Maintainer : Rob Dockins + +This module defines a @MuxTree@ type that notionally represents +a collection of values organized into an if-then-else tree. This +data structure allows values that otherwise do not have a useful notion +of symbolic values to nonetheless be merged as control flow merge points +by simply remembering which concrete values were obtained, and the +logical conditions under which they were found. + +Note that we require an @Ord@ instance on the type @a@ over which we are +building the mux trees. It is sufficent that this operation be merely +syntactic equality; it is not necessary for correctness that terms with +the same semantics compare equal. +-} + +{-# LANGUAGE FlexibleContexts #-} +module Lang.Crucible.Utils.MuxTree + ( MuxTree + , toMuxTree + , mergeMuxTree + , viewMuxTree + , muxTreeUnaryOp + , muxTreeBinOp + , muxTreeCmpOp + , collapseMuxTree + , muxTreeEq + , muxTreeLe + , muxTreeLt + , muxTreeGe + , muxTreeGt + ) where + +import Control.Lens (folded) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Merge.Strict as Map + +import What4.Interface +import Lang.Crucible.Panic + +-- | A mux tree represents a collection of if-then-else branches over +-- a collection of values. Generally, a mux tree is used to provide +-- a way to conditionally merge values that otherwise do not +-- naturally have a merge operation. +newtype MuxTree sym a = MuxTree (Map a (Pred sym)) +{- INVARIANT: The map inside a mux tree is non-empty! -} + +-- Turn a single value into a trivial mux tree +toMuxTree :: IsExprBuilder sym => sym -> a -> MuxTree sym a +toMuxTree sym v = MuxTree (Map.singleton v (truePred sym)) + +-- View all the leaf values of the mux tree, along with the +-- conditions that lead to those values. +viewMuxTree :: MuxTree sym a -> [(a, Pred sym)] +viewMuxTree (MuxTree m) = Map.toList m + +_conditionMuxTree :: IsExprBuilder sym => sym -> Pred sym -> MuxTree sym a -> IO (MuxTree sym a) +_conditionMuxTree sym p (MuxTree m) = MuxTree <$> Map.traverseMaybeWithKey (conditionMuxTreeLeaf sym p) m + +-- | Compute a binary boolean predicate between two mux trees. +-- This operation decomposes the mux trees and compares +-- all combinations of the underlying values, conditional on +-- the path conditions leading to those values. +muxTreeCmpOp :: + IsExprBuilder sym => + sym -> + (a -> a -> IO (Pred sym)) {- ^ compute the predicate on the underlying type -} -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeCmpOp sym f xt yt = orOneOf sym folded =<< sequence zs + where + zs = [ do pf <- f x y + andPred sym pf =<< andPred sym px py + | (x,px) <- xs + , (y,py) <- ys + ] + xs = viewMuxTree xt + ys = viewMuxTree yt + + +-- | Compute an equality predicate on mux trees. +-- +-- NOTE! This assumes the equality relation +-- defined by `Eq` is the semantic equality +-- relation on @a@. +muxTreeEq :: + (Eq a, IsExprBuilder sym) => + sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeEq sym = muxTreeCmpOp sym f + where f x y = pure (backendPred sym (x == y)) + +-- | Compute a less-than predicate on mux trees. +-- +-- NOTE! This assumes the order relation +-- defined by `Ord` is the semantic order +-- relation on @a@. +muxTreeLt :: + (Ord a, IsExprBuilder sym) => + sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeLt sym = muxTreeCmpOp sym f + where f x y = pure (backendPred sym (x < y)) + +-- | Compute a less-than-or-equal predicate on mux trees. +-- +-- NOTE! This assumes the order relation +-- defined by `Ord` is the semantic order +-- relation on @a@. +muxTreeLe :: + (Ord a, IsExprBuilder sym) => + sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeLe sym = muxTreeCmpOp sym f + where f x y = pure (backendPred sym (x <= y)) + +-- | Compute a greater-than predicate on mux trees. +-- +-- NOTE! This assumes the order relation +-- defined by `Ord` is the semantic order +-- relation on @a@. +muxTreeGt :: + (Ord a, IsExprBuilder sym) => + sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeGt sym = muxTreeCmpOp sym f + where f x y = pure (backendPred sym (x > y)) + +-- | Compute a greater-than-or-equal predicate on mux trees. +-- +-- NOTE! This assumes the order relation +-- defined by `Ord` is the semantic order +-- relation on @a@. +muxTreeGe :: + (Ord a, IsExprBuilder sym) => + sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (Pred sym) +muxTreeGe sym = muxTreeCmpOp sym f + where f x y = pure (backendPred sym (x >= y)) + + +-- | Use the provided if-then-else operation to collapse the given mux tree +-- into its underlying type. +collapseMuxTree :: + IsExprBuilder sym => + sym -> + (Pred sym -> a -> a -> IO a) -> + MuxTree sym a -> + IO a +collapseMuxTree _sym ite xt = go (viewMuxTree xt) + where + go [] = panic "collapseMuxTree" ["empty mux tree"] + go [(x,_p)] = return x + go ((x,p):xs) = ite p x =<< go xs + +buildMuxTree :: + (Ord a, IsExprBuilder sym) => + sym -> + [(a, Pred sym)] -> + IO (MuxTree sym a) +buildMuxTree _sym [] = panic "buildMuxTree" ["empty mux tree"] +buildMuxTree sym xs = go Map.empty xs + where + go m [] = return (MuxTree m) + go m ((z,p):zs) = + case Map.lookup z m of + Nothing -> go (Map.insert z p m) zs + Just q -> do pq <- orPred sym p q + case asConstantPred pq of + Just False -> go m zs + _ -> go (Map.insert z pq m) zs + +-- | Apply a unary operation through a mux tree. The provided operation +-- is applied to each leaf of the tree. +muxTreeUnaryOp :: + (Ord b, IsExprBuilder sym) => + sym -> + (a -> IO b) -> + MuxTree sym a -> + IO (MuxTree sym b) +muxTreeUnaryOp sym op xt = + do let xs = viewMuxTree xt + zs <- sequence + [ do z <- op x + return (z,p) + | (x,p) <- xs + ] + buildMuxTree sym zs + +-- | Apply a binary operation through two mux trees. The provided operation +-- is applied pairwise to each leaf of the two trees, and appropriate path +-- conditions are computed for the resulting values. +muxTreeBinOp :: + (Ord c, IsExprBuilder sym) => + sym -> + (a -> b -> IO c) -> + MuxTree sym a -> + MuxTree sym b -> + IO (MuxTree sym c) +muxTreeBinOp sym op xt yt = + do let xs = viewMuxTree xt + let ys = viewMuxTree yt + zs <- sequence + [ do p <- andPred sym px py + z <- op x y + return (z,p) + | (x,px) <- xs + , (y,py) <- ys + ] + buildMuxTree sym zs + + +conditionMuxTreeLeaf :: + IsExprBuilder sym => sym -> Pred sym -> a -> Pred sym -> IO (Maybe (Pred sym)) +conditionMuxTreeLeaf sym p _v pv = + do p' <- andPred sym p pv + case asConstantPred p' of + Just False -> return Nothing + _ -> return (Just p') + +-- | Compute the if-then-else operation on mux trees. +mergeMuxTree :: + (Ord a, IsExprBuilder sym) => + sym -> + Pred sym -> + MuxTree sym a -> + MuxTree sym a -> + IO (MuxTree sym a) +mergeMuxTree sym p (MuxTree mx) (MuxTree my) = + do np <- notPred sym p + MuxTree <$> doMerge np mx my + + where + f _v px py = + do p' <- itePred sym p px py + case asConstantPred p' of + Just False -> return Nothing + _ -> return (Just p') + + doMerge np = Map.mergeA (Map.traverseMaybeMissing (conditionMuxTreeLeaf sym p)) + (Map.traverseMaybeMissing (conditionMuxTreeLeaf sym np)) + (Map.zipWithMaybeAMatched f) diff --git a/src/Lang/Crucible/Utils/PrettyPrint.hs b/src/Lang/Crucible/Utils/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/PrettyPrint.hs @@ -0,0 +1,16 @@ +module Lang.Crucible.Utils.PrettyPrint + ( commas + , ppFn + ) where + +import Data.Maybe +import Prettyprinter as PP + +ppFn :: String -> [Doc ann] -> Doc ann +ppFn f a = pretty f <> parens (commas a) + +-- | Print a comma separated list. +commas :: Foldable f => f (Doc ann) -> Doc ann +commas l = fromMaybe mempty $ foldl go Nothing l + where go Nothing y = Just y + go (Just x) y = Just (x <> pretty ',' <+> y) diff --git a/src/Lang/Crucible/Utils/RegRewrite.hs b/src/Lang/Crucible/Utils/RegRewrite.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/RegRewrite.hs @@ -0,0 +1,253 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.Utils.RegRewrite +-- Description : Operations for manipulating registerized CFGs +-- Copyright : (c) Galois, Inc 2014-2018 +-- License : BSD3 +-- Maintainer : Luke Maurer +-- Stability : provisional +-- +-- A rewrite engine for registerized CFGs. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Lang.Crucible.Utils.RegRewrite + ( -- * Main interface + annotateCFGStmts + -- * Annotation monad + , Rewriter + , addStmt + , addInternalStmt + , ifte + , freshAtom + ) where + +import Control.Monad.RWS.Strict +import Control.Monad.State.Strict ( StateT, evalStateT ) +import Control.Monad.ST ( ST, runST ) +import Data.Foldable ( toList ) +import Data.Parameterized.Map ( MapF ) +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Nonce ( Nonce, NonceGenerator, freshNonce + , newSTNonceGenerator ) +import Data.Parameterized.Some ( Some(Some) ) +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set + +import What4.ProgramLoc + +import Lang.Crucible.CFG.Extension +import Lang.Crucible.CFG.Reg +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- Public interface + +-- | Add statements to each block in a CFG according to the given +-- instrumentation functions. See the 'Rewriter' monad for the +-- operations provided for adding code. +annotateCFGStmts :: TraverseExt ext + => u + -- ^ Initial user state + -> (forall s h. Posd (Stmt ext s) -> Rewriter ext h s ret u ()) + -- ^ Action to run on each non-terminating statement; + -- must explicitly add the original statement back if + -- desired + -> (forall s h. Posd (TermStmt s ret) -> Rewriter ext h s ret u ()) + -- ^ Action to run on each terminating statement + -> SomeCFG ext init ret + -- ^ Graph to rewrite + -> SomeCFG ext init ret +annotateCFGStmts u fS fT (SomeCFG cfg) = + runRewriter u $ + do cfg1 <- renameAll cfg + blocks' <- mapM (annotateBlockStmts fS fT) (cfgBlocks cfg1) + SomeCFG <$> newCFG cfg1 (concat blocks') + +-- | Monad providing operations for modifying a basic block by adding +-- statements and/or splicing in conditional braches. Also provides a +-- 'MonadState' instance for storing user state. +newtype Rewriter ext h s (ret :: CrucibleType) u a = + Rewriter (RWST (NonceGenerator (ST h) s) + (Seq (ComplexStmt ext s)) + u (ST h) a) + deriving ( Functor, Applicative, Monad, MonadState u + , MonadWriter (Seq (ComplexStmt ext s)) + ) + +-- | Add a new statement at the current position. +addStmt :: Posd (Stmt ext s) -> Rewriter ext h s ret u () +addStmt stmt = tell (Seq.singleton (Stmt stmt)) + +-- | Add a new statement at the current position, marking it as +-- internally generated. +addInternalStmt :: Stmt ext s -> Rewriter ext h s ret u () +addInternalStmt = addStmt . Posd InternalPos + +-- | Add a conditional at the current position. This will cause the +-- current block to end and new blocks to be generated for the two +-- branches and the remaining statements in the original block. +ifte :: Atom s BoolType + -> Rewriter ext h s ret u () + -> Rewriter ext h s ret u () + -> Rewriter ext h s ret u () +ifte atom thn els = + do (~(), thnSeq) <- gather thn + (~(), elsSeq) <- gather els + tell $ Seq.singleton (IfThenElse atom thnSeq elsSeq) + +-- | Create a new atom with a freshly allocated id. The id will not +-- have been used anywhere in the original CFG. +freshAtom :: TypeRepr tp -> Rewriter ext h s ret u (Atom s tp) +freshAtom tp = + do ng <- Rewriter $ ask + n <- Rewriter $ lift $ freshNonce ng + return $ Atom { atomPosition = InternalPos + , atomId = n + , atomSource = Assigned + , typeOfAtom = tp } + +------------------------------------------------------------------------ +-- Monad +-- +-- For each block, rewriting occurs in two stages: +-- +-- 1. Generate a sequence of "complex statements", each of which may +-- be an internal if-then-else. +-- 2. Rebuild the block from the complex statements, creating +-- additional blocks for internal control flow. +-- +-- Step 1 occurs through a simple writer monad, leaving the nasty details +-- of block mangling to step 2. + +data ComplexStmt ext s + = Stmt (Posd (Stmt ext s)) + | IfThenElse (Atom s BoolType) + (Seq (ComplexStmt ext s)) + (Seq (ComplexStmt ext s)) + +runRewriter :: forall u ext ret a + . u -> (forall h s. Rewriter ext h s ret u a) -> a +runRewriter u m = runST $ do + Some ng <- newSTNonceGenerator + case m of + -- Have to do this pattern match *after* unpacking the Some from + -- newSTNonceGenerator for obscure reasons involving Skolem + -- functions + Rewriter f -> do + (a, _, _) <- runRWST f ng u + return a + +freshLabel :: forall ext h s ret u. Rewriter ext h s ret u (Label s) +freshLabel = + do ng <- Rewriter $ ask + n <- Rewriter $ lift $ freshNonce ng + return $ Label { labelId = n } + +-- | Return the output of a writer action without passing it onward. +gather :: MonadWriter w m => m a -> m (a, w) +gather m = censor (const mempty) $ listen m + +------------------------------------------------------------------------ +-- Implementation + +-- Give fresh names to everything. The only point of this is that the +-- new names come from a known nonce generator, so we can now generate +-- more names. We do this in a separate pass up front so that we +-- don't have to juggle two namespaces afterward. +renameAll :: forall s0 s ext init ret h u + . ( TraverseExt ext ) + => CFG ext s0 init ret + -> Rewriter ext h s ret u (CFG ext s init ret) +renameAll cfg = do + ng <- Rewriter $ ask + Rewriter $ lift $ evalStateT (substCFG (rename ng) cfg) MapF.empty + where + rename :: NonceGenerator (ST h) s + -> Nonce s0 (tp :: CrucibleType) + -> StateT (MapF @CrucibleType (Nonce s0) (Nonce s)) (ST h) (Nonce s tp) + rename ng n = do + mapping <- get + case MapF.lookup n mapping of + Just n' -> + return n' + Nothing -> do + n' <- lift $ freshNonce ng + modify (MapF.insert n n') + return n' + +newCFG :: CFG ext s init ret + -> [Block ext s ret] + -> Rewriter ext h s ret u (CFG ext s init ret) +newCFG cfg blocks = do + return $ cfg { cfgBlocks = blocks } + +annotateBlockStmts :: TraverseExt ext + => (Posd (Stmt ext s) -> Rewriter ext h s ret u ()) + -> (Posd (TermStmt s ret) -> Rewriter ext h s ret u ()) + -> Block ext s ret + -> Rewriter ext h s ret u [Block ext s ret] +annotateBlockStmts fS fT block = + do -- Step 1 + stmts <- annotateAsComplexStmts fS fT block + -- Step 2 + rebuildBlock stmts block + +annotateAsComplexStmts :: (Posd (Stmt ext s) -> Rewriter ext h s ret u ()) + -> (Posd (TermStmt s ret) -> Rewriter ext h s ret u ()) + -> Block ext s ret + -> Rewriter ext h s ret u (Seq (ComplexStmt ext s)) +annotateAsComplexStmts fS fT block = + do (~(), stmts) <- gather $ + do mapM_ fS (blockStmts block) + fT (blockTerm block) + return stmts + +rebuildBlock :: TraverseExt ext + => Seq (ComplexStmt ext s) + -> Block ext s ret + -> Rewriter ext h s ret u [Block ext s ret] +rebuildBlock stmts block = + toList <$> go stmts Seq.empty Seq.empty + (blockID block) (blockExtraInputs block) (blockTerm block) + where + go :: TraverseExt ext + => Seq (ComplexStmt ext s) -- Statements to process + -> Seq (Posd (Stmt ext s)) -- Statements added to current block + -> Seq (Block ext s ret) -- Blocks created so far + -> BlockID s -- Id of current block + -> ValueSet s -- Extra inputs to current block + -> Posd (TermStmt s ret) -- Terminal statement of current block + -> Rewriter ext h s ret u (Seq (Block ext s ret)) + go s accStmts accBlocks bid ext term = case s of + Seq.Empty -> + return $ accBlocks Seq.|> mkBlock bid ext accStmts term + (Stmt stmt Seq.:<| s') -> + go s' (accStmts Seq.|> stmt) accBlocks bid ext term + (IfThenElse a thn els Seq.:<| s') -> + do thnLab <- freshLabel + elsLab <- freshLabel + newLab <- freshLabel + -- End the block, terminating with a branch statement + let branch = Posd InternalPos (Br a thnLab elsLab) + thisBlock = mkBlock bid ext accStmts branch + -- Make the branches into (sets of) blocks + let jump = Posd InternalPos (Jump newLab) + thnBlocks <- + go thn Seq.empty Seq.empty (LabelID thnLab) Set.empty jump + elsBlocks <- + go els Seq.empty Seq.empty (LabelID elsLab) Set.empty jump + -- Keep going with a new, currently empty block + let accBlocks' = (accBlocks Seq.|> thisBlock) Seq.>< + thnBlocks Seq.>< elsBlocks + go s' Seq.empty accBlocks' (LabelID newLab) Set.empty term diff --git a/src/Lang/Crucible/Utils/StateContT.hs b/src/Lang/Crucible/Utils/StateContT.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/StateContT.hs @@ -0,0 +1,101 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.Utils.StateContT +-- Description : A monad providing continuations and state. +-- Copyright : (c) Galois, Inc 2013-2014 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module defines a monad with continuations and state. By using this +-- instead of a MTL StateT and ContT transformer stack, one can have a +-- continuation that implements MonadCont and MonadState, yet never +-- returns the final state. This also wraps MonadST. +------------------------------------------------------------------------ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module Lang.Crucible.Utils.StateContT + ( StateContT(..) + -- * Re-exports + , Control.Monad.Cont.Class.MonadCont(..) + , Control.Monad.State.Class.MonadState(..) + ) where + +import Control.Monad.Cont.Class (MonadCont(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Catch ( MonadThrow(..), MonadCatch(..) ) + +import What4.Utils.MonadST + +-- | A monad transformer that provides @MonadCont@ and @MonadState@. +newtype StateContT s r m a + = StateContT { runStateContT :: (a -> s -> m r) + -> s + -> m r + } + +fmapStateContT :: (a -> b) -> StateContT s r m a -> StateContT s r m b +fmapStateContT = \f m -> StateContT $ \c -> runStateContT m (\v s -> (c $! f v) s) +{-# INLINE fmapStateContT #-} + +applyStateContT :: StateContT s r m (a -> b) -> StateContT s r m a -> StateContT s r m b +applyStateContT = \mf mv -> + StateContT $ \c -> + runStateContT mf (\f -> runStateContT mv (\v s -> (c $! f v) s)) +{-# INLINE applyStateContT #-} + +returnStateContT :: a -> StateContT s r m a +returnStateContT = \v -> seq v $ StateContT $ \c -> c v +{-# INLINE returnStateContT #-} + +bindStateContT :: StateContT s r m a -> (a -> StateContT s r m b) -> StateContT s r m b +bindStateContT = \m n -> StateContT $ \c -> runStateContT m (\a -> runStateContT (n a) c) +{-# INLINE bindStateContT #-} + +instance Functor (StateContT s r m) where + fmap = fmapStateContT + +instance Applicative (StateContT s r m) where + pure = returnStateContT + (<*>) = applyStateContT + +instance Monad (StateContT s r m) where + (>>=) = bindStateContT + +instance MonadFail m => MonadFail (StateContT s r m) where + fail = \msg -> StateContT $ \_ _ -> fail msg + +instance MonadCont (StateContT s r m) where + callCC f = StateContT $ \c -> runStateContT (f (\a -> seq a $ StateContT $ \_ s -> c a s)) c + +instance MonadState s (StateContT s r m) where + get = StateContT $ \c s -> c s s + put = \s -> seq s $ StateContT $ \c _ -> c () s + state f = StateContT $ \c s -> let (r,s') = f s in (c $! r) $! s' + +instance MonadTrans (StateContT s r) where + lift = \m -> StateContT $ \c s -> m >>= \v -> seq v (c v s) + +instance MonadIO m => MonadIO (StateContT s r m) where + liftIO = lift . liftIO + +instance MonadST s m => MonadST s (StateContT t r m) where + liftST = lift . liftST + +instance MonadReader v m => MonadReader v (StateContT s r m) where + ask = lift ask + local f m = StateContT $ \c s -> local f (runStateContT m c s) + +instance MonadThrow m => MonadThrow (StateContT s r m) where + throwM e = StateContT (\_k _s -> throwM e) + +instance MonadCatch m => MonadCatch (StateContT s r m) where + catch m hdl = + StateContT $ \k s -> + catch + (runStateContT m k s) + (\e -> runStateContT (hdl e) k s) diff --git a/src/Lang/Crucible/Utils/Structural.hs b/src/Lang/Crucible/Utils/Structural.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Utils/Structural.hs @@ -0,0 +1,72 @@ +{-| +Module : Lang.Crucible.Utils.Structural +Copyright : (c) Galois, Inc 2013-2016 +License : BSD3 +Maintainer : Joe Hendrix + +This module declares template Haskell primitives so that it is easier +to work with GADTs that have many constructors. +-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.Utils.Structural + ( structuralPretty + ) where + +import Data.Char (toLower) +import Language.Haskell.TH +import Language.Haskell.TH.Datatype +import Prettyprinter (brackets) + +import Data.Parameterized.TH.GADT +import Data.Parameterized.TraversableFC + +import Lang.Crucible.Utils.PrettyPrint (ppFn, commas) + +------------------------------------------------------------------------ +-- Contructor cases + +-- | @structuralPretty tp@ generates a function with the type +-- @forall f ann. (forall x. f x -> Doc ann) -> (forall x. tp f x -> Doc ann)@ +-- suitable for instantiating the @PrettyApp@ class. +structuralPretty :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ +structuralPretty tpq pats0 = do + d <- lookupDataType' =<< asTypeCon "structuralPretty" =<< tpq + pp <- newName "pp" + a <- newName "a" + + let pats = assocTypePats (dataParamTypes d) pats0 + lamE [varP pp, varP a] $ + caseE (varE a) (matchPretty pats (varE pp) <$> datatypeCons d) + +matchPretty :: (Type -> Q (Maybe ExpQ)) -- ^ Pattern match functions + -> ExpQ + -> ConstructorInfo + -> MatchQ +matchPretty matchPat pp con = do + let nm = constructorName con + tps = constructorFields con + (pat,nms) <- conPat con "x" + let vars = varE <$> nms + let nm' = case nameBase nm of + c:r -> toLower c : r + [] -> error "matchPretty given constructor with empty name." + let mkPP0 v tp = do + me <- matchPat tp + case me of + Nothing -> mkPP v tp + Just f -> [| $(f) $(pp) $(v)|] + mkPP v ConT{} = [| viaShow $(v) |] + mkPP v (AppT VarT{} _) = appE pp v + mkPP v (AppT (ConT cnm) _) + | nameBase cnm `elem` [ "Vector" ] + = [| brackets (commas (fmap $(pp) $(v))) |] + mkPP v (AppT (AppT (ConT cnm) _) _) + | nameBase cnm `elem` [ "Assignment" ] + = [| brackets (commas (toListFC $(pp) $(v))) |] + mkPP v _ = [| viaShow $(v) |] + --mkPP _ tp = error $ "Unsupported type " ++ show tp ++ " with " ++ nameBase nm + let rhs = [| ppFn $(litE (stringL nm')) $(listE (zipWith mkPP0 vars tps)) |] + match (pure pat) (normalB rhs) [] diff --git a/src/Lang/Crucible/Vector.hs b/src/Lang/Crucible/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/Vector.hs @@ -0,0 +1,107 @@ +{-# Language GADTs, DataKinds, TypeOperators #-} +{-# Language ScopedTypeVariables #-} +{-# Language Rank2Types #-} +module Lang.Crucible.Vector + ( module Data.Parameterized.Vector + + -- ** Bit-vectors + , fromBV + , toBV + , joinVecBV + , splitVecBV + + ) where + +import Prelude hiding (length,zipWith) + +import Data.Coerce +import Data.Proxy + +import Data.Parameterized.NatRepr +import Data.Parameterized.Vector +import Data.Parameterized.Utils.Endian + +import Lang.Crucible.Types +import Lang.Crucible.Syntax (IsExpr(..)) +import Lang.Crucible.CFG.Expr ( App( BVConcat, BVSelect ) ) + +{- | Join the bit-vectors in a vector into a single large bit-vector. +The "Endian" parameter indicates which way to join the elemnts: +"LittleEndian" indicates that low vector indexes are less significant. -} +toBV :: forall f n w. (1 <= w, IsExpr f) => + Endian -> + NatRepr w -> + Vector n (f (BVType w)) -> f (BVType (n * w)) +toBV endian w xs = ys + where + xs' = coerceVec xs + + jn :: (1 <= b) => NatRepr b -> Bits f w -> Bits f b -> Bits f (w + b) + jn = case endian of + LittleEndian -> jnLittle w + BigEndian -> jnBig w + + Bits ys = joinWith jn w xs' +{-# Inline toBV #-} + +coerceVec :: Coercible a b => Vector n a -> Vector n b +coerceVec = coerce + +newtype Bits f n = Bits (f (BVType n)) + + +-- | Earlier indexes are more signficant. +jnBig :: (IsExpr f, 1 <= a, 1 <= b) => + NatRepr a -> NatRepr b -> + Bits f a -> Bits f b -> Bits f (a + b) +jnBig la lb (Bits a) (Bits b) = + case leqAdd (leqProof (Proxy :: Proxy 1) la) lb of { LeqProof -> + Bits (app (BVConcat la lb a b)) } +{-# Inline jnBig #-} + +-- | Earlier indexes are less signficant. +jnLittle :: (IsExpr f, 1 <= a, 1 <= b) => + NatRepr a -> NatRepr b -> + Bits f a -> Bits f b -> Bits f (a + b) +jnLittle la lb (Bits a) (Bits b) = + case leqAdd (leqProof (Proxy :: Proxy 1) lb) la of { LeqProof -> + case plusComm lb la of { Refl -> + Bits (app (BVConcat lb la b a)) }} +{-# Inline jnLittle #-} + +-- | Split a bit-vector into a vector of bit-vectors. +fromBV :: forall f w n. + (1 <= w, 1 <= n, IsExpr f) => + Endian -> + NatRepr n -> NatRepr w -> f (BVType (n * w)) -> Vector n (f (BVType w)) + +fromBV e n w xs = coerceVec (splitWith e sel n w (Bits xs)) + where + sel :: (i + w <= n * w) => + NatRepr (n * w) -> NatRepr i -> Bits f (n * w) -> Bits f w + sel totL i (Bits val) = + case leqMulPos n w of { LeqProof -> + Bits (app (BVSelect i w totL val)) } +{-# Inline fromBV #-} + +-- | Turn a vector of bit-vectors, +-- into a shorter vector of longer bit-vectors. +joinVecBV :: (IsExpr f, 1 <= i, 1 <= w, 1 <= n) => + Endian {- ^ How to append bit-vectors -} -> + NatRepr w {- ^ Width of bit-vectors in input -} -> + NatRepr i {- ^ Number of bit-vectors to join togeter -} -> + Vector (n * i) (f (BVType w)) -> + Vector n (f (BVType (i * w))) +joinVecBV e w i xs = toBV e w <$> split (divNat (length xs) i) i xs +{-# Inline joinVecBV #-} + + +-- | Turn a vector of large bit-vectors, +-- into a longer vector of shorter bit-vectors. +splitVecBV :: (IsExpr f, 1 <= i, 1 <= w) => + Endian -> + NatRepr i {- ^ Split bit-vectors in this many parts -} -> + NatRepr w {- ^ Length of bit-vectors in the result -} -> + Vector n (f (BVType (i * w))) -> Vector (n*i) (f (BVType w)) +splitVecBV e i w xs = join i (fromBV e i w <$> xs) +{-# Inline splitVecBV #-} diff --git a/test/absint/AI.hs b/test/absint/AI.hs new file mode 100644 --- /dev/null +++ b/test/absint/AI.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module AI ( + aiTests + ) where + +import Control.Monad ( guard, join ) +import Prelude + +import qualified Test.Tasty as T +import qualified Test.Tasty.HUnit as T + +import qualified Data.Parameterized.Context as PU +import qualified Data.Parameterized.Map as PM +import Data.Parameterized.Nonce + +import qualified What4.FunctionName as C +import qualified What4.ProgramLoc as P + +import qualified Lang.Crucible.FunctionHandle as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Expr as C +import qualified Lang.Crucible.CFG.Generator as G +import qualified Lang.Crucible.CFG.SSAConversion as SSA +import Lang.Crucible.Syntax +import Lang.Crucible.Analysis.Fixpoint hiding ( Ignore(..) ) + +import EvenOdd +import Max + +aiTests :: T.TestTree +aiTests = T.testGroup "Abstract Interpretation" [ + runTest "eo_p1" eo_p1, + runTest "eo_p2" eo_p2, + runTest "eo_p3" eo_p3, + runTest "eo_p4" eo_p4, + runTest "max_p1" max_p1, + runTest "max_p2" max_p2 + ] + +runTest :: (C.IsSyntaxExtension ext) => String -> TestCase ext dom -> T.TestTree +runTest name tc = T.testCase name $ join (testAI tc) + +testAI :: (C.IsSyntaxExtension ext) => TestCase ext dom -> IO T.Assertion +testAI TC { tcHandle = hdl + , tcDef = def + , tcGlobals = g + , tcAssignment = a0 + , tcCheck = check + , tcDom = dom + , tcInterp = interp + } = do + fh <- hdl + sng <- newIONonceGenerator + (G.SomeCFG cfg, _) <- G.defineFunction P.InternalPos sng fh def + case SSA.toSSA cfg of + C.SomeCFG cfg' -> do + let (assignment', rabs) = forwardFixpoint dom interp cfg' g a0 + mWorklist = do + -- If we aren't widening, also compute the same + -- approximation using the worklist-based iteration + -- strategy. The result should be the same. + guard (isWTOIter (domIter dom)) + let dom' = dom { domIter = Worklist } + return $ forwardFixpoint dom' interp cfg' g a0 + return (check cfg' assignment' rabs mWorklist) + +data TestCase ext dom = + forall init ret t . + TC { tcDef :: G.FunctionDef ext t init ret IO + , tcHandle :: IO (C.FnHandle init ret) + , tcDom :: Domain dom + , tcInterp :: Interpretation ext dom + , tcAssignment :: PU.Assignment dom init + , tcGlobals :: PM.MapF C.GlobalVar dom + , tcCheck :: forall blocks tp + . C.CFG ext blocks init ret + -> PU.Assignment (PointAbstraction blocks dom) blocks + -> dom tp + -> Maybe (PU.Assignment (PointAbstraction blocks dom) blocks, dom tp) + -> T.Assertion + } + +genHandle :: IO (C.FnHandle (C.EmptyCtx C.::> C.IntegerType) C.IntegerType) +genHandle = C.withHandleAllocator $ \ha -> C.mkHandle ha C.startFunctionName + +type EvenOdd' = Pointed EvenOdd +type Max' = Pointed Max + +eo_p1 :: TestCase EOExt EvenOdd' +eo_p1 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed Even + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = evenOddDom + , tcInterp = evenOddInterp + } + where + check _cfg _assignment rabs mWorklist = do + T.assertEqual "retVal" Top rabs + case mWorklist of + Nothing -> T.assertFailure "Expected worklist result" + Just (_, rabs') -> T.assertEqual "WL Result" rabs rabs' + + gen initialAssignment = do + r0 <- G.newReg (intLitReg 0) + let x = initialAssignment PU.! PU.baseIndex + let c = app (atom x `C.IntLt` litExpr 5) + G.ifte_ c (then_ r0) (else_ r0) + rval <- G.readReg r0 + G.returnFromFunction rval + + then_ r0 = do + G.assignReg r0 (litExpr (negate 5)) + + else_ r0 = do + G.assignReg r0 (litExpr 10) + +eo_p2 :: TestCase EOExt EvenOdd' +eo_p2 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed Even + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = evenOddDom + , tcInterp = evenOddInterp + } + where + check _cfg _assignment rabs mWorklist = do + T.assertEqual "retVal" (Pointed Even) rabs + case mWorklist of + Nothing -> T.assertFailure "Expected worklist result" + Just (_, rabs') -> do + T.assertEqual "WL Result" rabs rabs' + + gen initialAssignment = do + r0 <- G.newReg (intLitReg 0) + let x = initialAssignment PU.! PU.baseIndex + let c = app (atom x `C.IntLt` litExpr 5) + G.ifte_ c (then_ r0) (else_ r0) + rval <- G.readReg r0 + G.returnFromFunction rval + + then_ r0 = do + G.assignReg r0 (litExpr 6) + + else_ r0 = do + G.assignReg r0 (litExpr 10) + +eo_p3 :: TestCase EOExt EvenOdd' +eo_p3 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed Even + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = evenOddDom + , tcInterp = evenOddInterp + } + where + check _cfg _assignment rabs mWorklist = do + T.assertEqual "retVal" (Pointed Even) rabs + case mWorklist of + Nothing -> T.assertFailure "Expected worklist result" + Just (_, rabs') -> T.assertEqual "WL Result" rabs rabs' + + gen initialAssignment = do + r0 <- G.newReg (intLitReg 0) + r1 <- G.newReg (intLitReg 0) + let x = initialAssignment PU.! PU.baseIndex + let c = app (atom x `C.IntLt` litExpr 5) + G.ifte_ c (then_ r0 r1) (else_ r0 r1) + rval <- G.readReg r1 + G.returnFromFunction rval + + then_ r0 r1 = do + v <- G.readReg r0 + G.assignReg r1 (app (v `C.IntAdd` litExpr 2)) + + else_ r0 r1 = do + v <- G.readReg r0 + G.assignReg r1 (app (v `C.IntAdd` litExpr 10)) + +eo_p4 :: TestCase EOExt EvenOdd' +eo_p4 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed Even + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = evenOddDom + , tcInterp = evenOddInterp + } + where + check _cfg _assignment rabs mWorklist = do + T.assertEqual "retVal" (Pointed Odd) rabs + case mWorklist of + Nothing -> T.assertFailure "Expected worklist result" + Just (_, rabs') -> T.assertEqual "WL Result" rabs rabs' + + gen initialAssignment = do + r0 <- G.newReg (intLitReg 0) + r1 <- G.newReg (intLitReg 0) + let x = initialAssignment PU.! PU.baseIndex + let c = app (atom x `C.IntLt` litExpr 5) + G.ifte_ c (then_ r0 r1) (else_ r0 r1) + rval <- G.readReg r1 + G.returnFromFunction rval + + then_ r0 r1 = do + v <- G.readReg r0 + G.assignReg r1 (app (v `C.IntAdd` litExpr 3)) + + else_ r0 r1 = do + v <- G.readReg r0 + G.assignReg r1 (app (v `C.IntAdd` litExpr 11)) + +max_p1 :: TestCase SyntaxExt Max' +max_p1 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed (Max 5) + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = maxDom + , tcInterp = maxInterp + } + where + check _cfg _assignment rabs _ = + T.assertEqual "retVal" (Pointed (Max 11)) rabs + + gen initialAssignment = do + let x = initialAssignment PU.! PU.baseIndex + let c = app (atom x `C.IntLt` litExpr 5) + r0 <- G.newReg (atom x) + G.ifte_ c (then_ r0) (else_ r0) + rval <- G.readReg r0 + G.returnFromFunction rval + + then_ r0 = do + v <- G.readReg r0 + G.assignReg r0 (app (v `C.IntAdd` litExpr 5)) + + else_ r0 = do + v <- G.readReg r0 + G.assignReg r0 (app (v `C.IntAdd` litExpr 6)) + +max_p2 :: TestCase SyntaxExt Max' +max_p2 = TC { tcDef = \ia -> (Ignore, gen ia) + , tcHandle = genHandle + , tcAssignment = PU.empty PU.:> Pointed (Max 5) + , tcGlobals = PM.empty + , tcCheck = check + , tcDom = maxDom + , tcInterp = maxInterp + } + where + check _cfg _assignment rabs _ = do + T.assertEqual "retVal" Top rabs + + gen initialAssignment = do + let x = initialAssignment PU.! PU.baseIndex + r0 <- G.newReg (atom x) + G.while (P.InternalPos, test r0) (P.InternalPos, body r0) + rval <- G.readReg r0 + G.returnFromFunction rval + + test r0 = do + v <- G.readReg r0 + return (app (v `C.IntLt` litExpr 100)) + + body r0 = do + v <- G.readReg r0 + G.assignReg r0 (app (v `C.IntAdd` litExpr 1)) + + +intLitReg :: C.IsSyntaxExtension exp => Integer -> G.Expr exp s C.IntegerType +intLitReg i = litExpr i + +atom :: G.Atom s tp -> G.Expr exp s tp +atom = G.AtomExpr + +data Ignore i = Ignore + +isWTOIter :: IterationStrategy dom -> Bool +isWTOIter WTO = True +isWTOIter _ = False diff --git a/test/absint/EvenOdd.hs b/test/absint/EvenOdd.hs new file mode 100644 --- /dev/null +++ b/test/absint/EvenOdd.hs @@ -0,0 +1,97 @@ +-- | A simple domain for tracking even-ness and odd-ness of values +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +module EvenOdd ( + EvenOdd(..), EOExt, + evenOddDom, + evenOddInterp + ) where + +import qualified Data.Parameterized.Context as PU + +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Expr as C +import Lang.Crucible.Analysis.Fixpoint + +data EvenOdd (tp :: C.CrucibleType) where + Even :: EvenOdd tp + Odd :: EvenOdd tp + +deriving instance Eq (EvenOdd tp) +deriving instance Show (EvenOdd tp) + +instance C.ShowF EvenOdd + +type EvenOdd' = Pointed EvenOdd + +evenOddDom :: Domain EvenOdd' +evenOddDom = pointed j (==) WTO + where + j Even Odd = Top + j Odd Even = Top + j Even Even = Pointed Even + j Odd Odd = Pointed Odd + +type EOExt = () + +evenOddInterp :: Interpretation EOExt EvenOdd' +evenOddInterp = Interpretation { interpExpr = eoIExpr + , interpExt = undefined + , interpCall = eoICall + , interpReadGlobal = eoIRdGlobal + , interpWriteGlobal = eoIWrGlobal + , interpBr = eoIBr + , interpMaybe = eoIMaybe + } + +eoIExpr :: ScopedReg + -> C.TypeRepr tp + -> C.Expr ext ctx tp + -> PointAbstraction blocks EvenOdd' ctx + -> (Maybe (PointAbstraction blocks EvenOdd' ctx), EvenOdd' tp) +eoIExpr _sr _tr (C.App e) abstr = + case e of + C.IntLit i -> (Nothing, if i `mod` 2 == 0 then Pointed Even else Pointed Odd) + C.IntAdd r1 r2 -> + let a1 = lookupAbstractRegValue abstr r1 + a2 = lookupAbstractRegValue abstr r2 + in case (a1, a2) of + (Pointed Even, Pointed Even) -> (Nothing, Pointed Even) + (Pointed Odd, Pointed Odd) -> (Nothing, Pointed Even) + (Pointed Even, Pointed Odd) -> (Nothing, Pointed Odd) + (Pointed Odd, Pointed Even) -> (Nothing, Pointed Odd) + _ -> (Nothing, Top) + _ -> (Nothing, Top) + +eoICall :: C.CtxRepr args + -> C.TypeRepr ret + -> C.Reg ctx (C.FunctionHandleType args ret) + -> EvenOdd' (C.FunctionHandleType args ret) + -> PU.Assignment EvenOdd' args + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks EvenOdd' ctx), EvenOdd' ret) +eoICall _ _ _ _ _ _ = (Nothing, Top) + +eoIBr :: C.Reg ctx C.BoolType + -> EvenOdd' C.BoolType + -> C.JumpTarget blocks ctx + -> C.JumpTarget blocks ctx + -> PointAbstraction blocks EvenOdd' ctx + -> (Maybe (PointAbstraction blocks EvenOdd' ctx), Maybe (PointAbstraction blocks EvenOdd' ctx)) +eoIBr _ _ _ _ _ = (Nothing, Nothing) + +eoIMaybe :: C.TypeRepr tp + -> C.Reg ctx (C.MaybeType tp) + -> EvenOdd' (C.MaybeType tp) + -> PointAbstraction blocks EvenOdd' ctx + -> (Maybe (PointAbstraction blocks EvenOdd' ctx), EvenOdd' tp, Maybe (PointAbstraction blocks EvenOdd' ctx)) +eoIMaybe _ _ _ _ = (Nothing, Top, Nothing) + +eoIWrGlobal :: C.GlobalVar tp -> C.Reg ctx tp -> PointAbstraction blocks EvenOdd' ctx -> Maybe (PointAbstraction blocks EvenOdd' ctx) +eoIWrGlobal _ _ _ = Nothing + +eoIRdGlobal :: C.GlobalVar tp -> PointAbstraction blocks EvenOdd' ctx -> (Maybe (PointAbstraction blocks EvenOdd' ctx), EvenOdd' tp) +eoIRdGlobal _ _ = (Nothing, Top) diff --git a/test/absint/Main.hs b/test/absint/Main.hs new file mode 100644 --- /dev/null +++ b/test/absint/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main ( main ) where + +import qualified Test.Tasty as T + +import AI +import WTO + +main :: IO () +main = T.defaultMain $ T.testGroup "Abstract Interpretation Tests" [ + wtoTests, + aiTests + ] diff --git a/test/absint/Max.hs b/test/absint/Max.hs new file mode 100644 --- /dev/null +++ b/test/absint/Max.hs @@ -0,0 +1,95 @@ +-- | A domain for tracking the maximum value a register can take +-- +-- This is intentionally a very tall domain so that widening is +-- required. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +module Max ( + Max(..), SyntaxExt, + maxDom, + maxInterp + ) where + +import qualified Data.Parameterized.Context as PU + +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Expr as C +import Lang.Crucible.Analysis.Fixpoint + +data Max (tp :: C.CrucibleType) where + Max :: Int -> Max tp + +deriving instance Eq (Max tp) +deriving instance Show (Max tp) + +instance C.ShowF Max + +type Max' = Pointed Max + +maxDom :: Domain Max' +maxDom = d + where + d = pointed j (==) (WTOWidening (>10) w) + j (Max i1) (Max i2) = Pointed (Max (max i1 i2)) + w _ _ = Top + +type SyntaxExt = () + +maxInterp :: Interpretation SyntaxExt Max' +maxInterp = Interpretation { interpExpr = mExpr + , interpExt = undefined + , interpCall = mCall + , interpReadGlobal = mRdGlobal + , interpWriteGlobal = mWrGlobal + , interpBr = mBr + , interpMaybe = mMaybe + } + +mExpr :: ScopedReg + -> C.TypeRepr tp + -> C.Expr ext ctx tp + -> PointAbstraction blocks Max' ctx + -> (Maybe (PointAbstraction blocks Max' ctx), Max' tp) +mExpr _sr _tr (C.App e) abstr = + case e of + C.IntLit i -> (Nothing, Pointed (Max (fromIntegral i))) + C.IntAdd r1 r2 -> + let a1 = lookupAbstractRegValue abstr r1 + a2 = lookupAbstractRegValue abstr r2 + in case (a1, a2) of + (Pointed (Max m1), Pointed (Max m2)) -> (Nothing, Pointed (Max (m1 + m2))) + _ -> (Nothing, Top) + _ -> (Nothing, Top) + +mCall :: C.CtxRepr args + -> C.TypeRepr ret + -> C.Reg ctx (C.FunctionHandleType args ret) + -> Max' (C.FunctionHandleType args ret) + -> PU.Assignment Max' args + -> PointAbstraction blocks dom ctx + -> (Maybe (PointAbstraction blocks Max' ctx), Max' ret) +mCall _ _ _ _ _ _ = (Nothing, Top) + +mBr :: C.Reg ctx C.BoolType + -> Max' C.BoolType + -> C.JumpTarget blocks ctx + -> C.JumpTarget blocks ctx + -> PointAbstraction blocks Max' ctx + -> (Maybe (PointAbstraction blocks Max' ctx), Maybe (PointAbstraction blocks Max' ctx)) +mBr _ _ _ _ _ = (Nothing, Nothing) + +mMaybe :: C.TypeRepr tp + -> C.Reg ctx (C.MaybeType tp) + -> Max' (C.MaybeType tp) + -> PointAbstraction blocks Max' ctx + -> (Maybe (PointAbstraction blocks Max' ctx), Max' tp, Maybe (PointAbstraction blocks Max' ctx)) +mMaybe _ _ _ _ = (Nothing, Top, Nothing) + +mWrGlobal :: C.GlobalVar tp -> C.Reg ctx tp -> PointAbstraction blocks Max' ctx -> Maybe (PointAbstraction blocks Max' ctx) +mWrGlobal _ _ _ = Nothing + +mRdGlobal :: C.GlobalVar tp -> PointAbstraction blocks Max' ctx -> (Maybe (PointAbstraction blocks Max' ctx), Max' tp) +mRdGlobal _ _ = (Nothing, Top) diff --git a/test/absint/WTO.hs b/test/absint/WTO.hs new file mode 100644 --- /dev/null +++ b/test/absint/WTO.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +module WTO ( + wtoTests + ) where + +import Control.Applicative +import Control.Monad ( replicateM, unless ) +import qualified Control.Monad.State.Strict as St +import qualified Data.Foldable as F +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Prelude + +import qualified Test.QuickCheck as QC +import qualified Test.Tasty as T +import qualified Test.Tasty.QuickCheck as T + +import Lang.Crucible.Analysis.Fixpoint.Components + +wtoTests :: T.TestTree +wtoTests = T.testGroup "WeakTopologicalOrdering" [ + T.testProperty "prop_reachableInWTO" prop_reachableInWTO, + T.testProperty "prop_validWTO" prop_validWTO + ] + +-- | Test that all reachable nodes in the graph are present in the +-- weak topological ordering +prop_reachableInWTO :: RandomGraph -> Bool +prop_reachableInWTO gp = dfsReachedNodes dfs == S.fromList (concatMap F.toList wto) + where + dfs = reachable gp + (root, sf) = toCFG gp + wto = weakTopologicalOrdering sf root + +-- | Test that the weak topological ordering property holds for the +-- WTO we compute. +-- +-- That property is defined in terms of a relation w(c), which +-- evaluates to the set of heads of the nested components containing +-- the vertex c. +-- +-- For every edge u->v: +-- +-- (u < v AND v not in w(u)) OR (v <= u AND v in w(u)) +-- +-- where v <= u means that u->v is a backedge. +prop_validWTO :: RandomGraph -> Bool +prop_validWTO gp@(RG edges) = + and [ (isBackEdge e && (v `vertexInWC` u)) || not (v `vertexInWC` u) + | e@(u, v) <- edges + , isReachableEdge e + ] + where + dfs = reachable gp + (root, sf) = toCFG gp + wto = weakTopologicalOrdering sf root + cchs = indexContainingComponentHeads wto + isReachableEdge (src, _) = src `S.member` dfsReachedNodes dfs + isBackEdge e = e `S.member` dfsBackEdges dfs + vertexInWC v c = maybe False (S.member v) $ M.lookup c cchs + +-- | This is the w(c) relation from the WTO criteria +-- +-- The map keys are the cs +indexContainingComponentHeads :: (Ord n) => [WTOComponent n] -> M.Map n (S.Set n) +indexContainingComponentHeads cs = St.execState (mapM_ (go []) cs) M.empty + where + go heads c = + case c of + Vertex v -> St.modify' $ M.insert v (S.fromList heads) + SCC (SCCData { wtoHead = h + , wtoComps = cs' + }) -> do + let heads' = h : heads + St.modify' $ M.insert h (S.fromList heads') + mapM_ (go heads') cs' + +newtype NodeId = NID Int + deriving (Eq, Show) + +instance QC.Arbitrary NodeId where + arbitrary = QC.sized mkNodeId + where + mkNodeId n = NID <$> QC.choose (0, n) + +newtype RandomGraph = RG [(Int, Int)] + deriving (Show) + +instance QC.Arbitrary RandomGraph where + arbitrary = QC.sized mkRandomGraph + +-- | Make an arbitrary graph by deciding on a number of edges and then +-- generating random edges. Note that we always increment the size so +-- that we don't get empty graphs. +-- +-- The graphs are not all connected. +mkRandomGraph :: Int -> QC.Gen RandomGraph +mkRandomGraph ((+1) -> sz) = do + nEdges <- QC.choose (2, 2*sz) + srcs <- replicateM nEdges (QC.choose (0, sz)) + dsts <- replicateM nEdges (QC.choose (0, sz)) + return $! RG (unique (zip srcs dsts)) + +-- | A DFS result; it additionally contains a list of back edges +-- discovered during its traversal +data DFS = DFS { dfsReachedNodes :: S.Set Int + , dfsBackEdges :: S.Set (Int, Int) + , dfsStart :: S.Set Int + , dfsFinish :: S.Set Int + } + +-- | Compute the DFS of a random graph from its root. +reachable :: RandomGraph -> DFS +reachable gp = + St.execState (go root) s0 + where + s0 = DFS { dfsReachedNodes = S.empty + , dfsBackEdges = S.empty + , dfsStart = S.empty + , dfsFinish = S.empty + } + (root, sf) = toCFG gp + go n = do + markDiscovered n + F.forM_ (sf n) $ \successor -> do + disc <- isDiscovered successor + case disc of + False -> go successor + True -> do + fin <- isFinished successor + unless fin $ addBackedge (n, successor) + markFinished n + +type M a = St.State DFS a + +markDiscovered :: Int -> M () +markDiscovered v = St.modify' $ \s -> + s { dfsReachedNodes = S.insert v (dfsReachedNodes s) + , dfsStart = S.insert v (dfsStart s) + } + +markFinished :: Int -> M () +markFinished v = St.modify' $ \s -> + s { dfsFinish = S.insert v (dfsFinish s) } + +addBackedge :: (Int, Int) -> M () +addBackedge be = St.modify' $ \s -> s { dfsBackEdges = S.insert be (dfsBackEdges s) } + +isDiscovered :: Int -> M Bool +isDiscovered n = S.member n <$> St.gets dfsReachedNodes + +isFinished :: Int -> M Bool +isFinished n = S.member n <$> St.gets dfsFinish + +unique :: (Ord a) => [a] -> [a] +unique = S.toList . S.fromList + +-- | Return the root and the successor function for the graph. +-- +-- Not defined for empty graphs +toCFG :: RandomGraph -> (Int, (Int -> [Int])) +toCFG (RG []) = error "Empty graph" +toCFG (RG edges@((s0, _) : _)) = + (s0, \n -> [ dst | (src, dst) <- edges, n == src]) + + diff --git a/test/helpers/Main.hs b/test/helpers/Main.hs new file mode 100644 --- /dev/null +++ b/test/helpers/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Main where + +import Data.List (isInfixOf) + +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec (testSpec) + +import Lang.Crucible.Panic + +import qualified Panic as P + +main :: IO () +main = + defaultMain =<< panicTests + +panicTests :: IO TestTree +panicTests = + do t <- testSpec "Panicking throws an exception" $ + describe "panic" $ + it "should throw an exception with the right details" $ + shouldThrow (panic "Oh no!" ["line 1", "line 2"]) acceptableExn + pure $ testGroup "panic" [ t ] + where + acceptableExn :: P.Panic Crucible -> Bool + acceptableExn e = + let exnMessage = show e + in isInfixOf "Crucible" exnMessage && + isInfixOf "github.com/GaloisInc/crucible/issues" exnMessage