packages feed

crucible (empty) → 0.7

raw patch · 63 files changed

+22631/−0 lines, 63 filesdep +QuickCheckdep +basedep +bimapsetup-changed

Dependencies added: QuickCheck, base, bimap, bv-sized, containers, crucible, exceptions, fgl, hashable, hspec, json, lens, mtl, panic, parameterized-utils, prettyprinter, tasty, tasty-hspec, tasty-hunit, tasty-quickcheck, template-haskell, text, th-abstraction, time, transformers, unordered-containers, vector, what4

Files

+ CHANGELOG.md view
@@ -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`.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ crucible.cabal view
@@ -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
+ src/Lang/Crucible/Analysis/DFS.hs view
@@ -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 <rdockins@galois.com>+-- 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)
+ src/Lang/Crucible/Analysis/Fixpoint.hs view
@@ -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 <tristan@galois.com>+-- 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
+ src/Lang/Crucible/Analysis/Fixpoint/Components.hs view
@@ -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 <tristan@galois.com>+-- 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.++-}
+ src/Lang/Crucible/Analysis/ForwardDataflow.hs view
@@ -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 <rdockins@galois.com>+-- 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'
+ src/Lang/Crucible/Analysis/Postdom.hs view
@@ -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 <jhendrix@galois.com>+-- 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 ++ "."
+ src/Lang/Crucible/Analysis/Reachable.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Backend.hs view
@@ -0,0 +1,632 @@+{-|+Module      : Lang.Crucible.Backend+Copyright   : (c) Galois, Inc 2014-2022+License     : BSD3+Maintainer  : Joe Hendrix <jhendrix@galois.com>++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)]
+ src/Lang/Crucible/Backend/AssumptionStack.hs view
@@ -0,0 +1,256 @@+{-|+Module      : Lang.Crucible.Backend.AssumptionStack+Copyright   : (c) Galois, Inc 2018+License     : BSD3+Maintainer  : Rob Dockins <rdockins@galois.com>++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))
+ src/Lang/Crucible/Backend/Online.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/Lang/Crucible/Backend/ProofGoals.hs view
@@ -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
+ src/Lang/Crucible/Backend/Simple.hs view
@@ -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 <rdockins@galois.com>+-- 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)
+ src/Lang/Crucible/CFG/Common.hs view
@@ -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 <jhendrix@galois.com>++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
+ src/Lang/Crucible/CFG/Core.hs view
@@ -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 <jhendrix@galois.com>++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
+ src/Lang/Crucible/CFG/EarlyMergeLoops.hs view
@@ -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
+ src/Lang/Crucible/CFG/Expr.hs view
@@ -0,0 +1,1576 @@+{- |+Module           : Lang.Crucible.CFG.Expr+Description      : Expression syntax definitions+Copyright        : (c) Galois, Inc 2014-2016+License          : BSD3+Maintainer       : Joe Hendrix <jhendrix@galois.com>++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)
+ src/Lang/Crucible/CFG/Extension.hs view
@@ -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 <rdockins@galois.com>++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 ()
+ src/Lang/Crucible/CFG/ExtractSubgraph.hs view
@@ -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
+ src/Lang/Crucible/CFG/Generator.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/Lang/Crucible/CFG/Reg.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/CFG/SSAConversion.hs view
@@ -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 <jhendrix@galois.com>+-- 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'
+ src/Lang/Crucible/FunctionHandle.hs view
@@ -0,0 +1,238 @@+{-+Module           : Lang.Crucible.FunctionHandle+Copyright        : (c) Galois, Inc 2014-2016+Maintainer       : Joe Hendrix <jhendrix@galois.com>+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)
+ src/Lang/Crucible/Panic.hs view
@@ -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
+ src/Lang/Crucible/Simulator.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/BoundedExec.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/BoundedRecursion.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/Breakpoint.hs view
@@ -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 <andrei@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/CallFrame.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/EvalStmt.hs view
@@ -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 <jhendrix@galois.com>+-- 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)))
+ src/Lang/Crucible/Simulator/Evaluation.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/ExecutionTree.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/Lang/Crucible/Simulator/GlobalState.hs view
@@ -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)+           ]
+ src/Lang/Crucible/Simulator/Intrinsics.hs view
@@ -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 <rdockins@galois.com>+-- 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+        ]
+ src/Lang/Crucible/Simulator/Operations.hs view
@@ -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 <jhendrix@galois.com>+-- 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 "<function entry>")+         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 "<function entry>")+     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                   -> []
+ src/Lang/Crucible/Simulator/OverrideSim.hs view
@@ -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 <jhendrix@galois.com>++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)
+ src/Lang/Crucible/Simulator/PathSatisfiability.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/PathSplitting.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/PositionTracking.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/Profiling.hs view
@@ -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 <rdockins@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/RegMap.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/RegValue.hs view
@@ -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 <jhendrix@galois.com>+-- 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))
+ src/Lang/Crucible/Simulator/SimError.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Simulator/SymSequence.hs view
@@ -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
+ src/Lang/Crucible/Syntax.hs view
@@ -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 <jhendrix@galois.com>+-- 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!"
+ src/Lang/Crucible/Types.hs view
@@ -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 <jhendrix@galois.com>+-- 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|])+                   ]+                  )
+ src/Lang/Crucible/Utils/BitSet.hs view
@@ -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 <jhendrix@galois.com>+-- 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
+ src/Lang/Crucible/Utils/CoreRewrite.hs view
@@ -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 <sjw@galois.com>+-- 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'
+ src/Lang/Crucible/Utils/MonadVerbosity.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/Lang/Crucible/Utils/MuxTree.hs view
@@ -0,0 +1,258 @@+{-|+Module           : Lang.Crucible.Utils.MuxTree+Copyright        : (c) Galois, Inc 2018+License          : BSD3+Maintainer       : Rob Dockins <rdockins@galois.com>++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)
+ src/Lang/Crucible/Utils/PrettyPrint.hs view
@@ -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)
+ src/Lang/Crucible/Utils/RegRewrite.hs view
@@ -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 <lukemaurer@galois.com>+-- 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
+ src/Lang/Crucible/Utils/StateContT.hs view
@@ -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 <jhendrix@galois.com>+-- 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)
+ src/Lang/Crucible/Utils/Structural.hs view
@@ -0,0 +1,72 @@+{-|+Module     : Lang.Crucible.Utils.Structural+Copyright  : (c) Galois, Inc 2013-2016+License    : BSD3+Maintainer : Joe Hendrix <jhendrix@galois.com>++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) []
+ src/Lang/Crucible/Vector.hs view
@@ -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 #-}
+ test/absint/AI.hs view
@@ -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
+ test/absint/EvenOdd.hs view
@@ -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)
+ test/absint/Main.hs view
@@ -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+  ]
+ test/absint/Max.hs view
@@ -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)
+ test/absint/WTO.hs view
@@ -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])++
+ test/helpers/Main.hs view
@@ -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