------------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.LLVM.SimpleLoopFixpointCHC
-- Description      : Execution feature to compute loop fixpoint in
--                    conjunction with CHC
-- Copyright        : (c) Galois, Inc 2021
-- License          : BSD3
-- Stability        : provisional
--
-- This offers a similar API to what is offered in
-- "Lang.Crucible.LLVM.SimpleLoopFixpoint", but this generates proof obligations
-- involving a predicate function (named @inv@). The intent is that a user will
-- leverage Z3's constrained horn-clause (CHC) functionality to synthesize an
-- implementation of @inv@ and then substitute it back into the proof
-- obligations.
------------------------------------------------------------------------

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}


module Lang.Crucible.LLVM.SimpleLoopFixpointCHC
  ( FixpointEntry(..)
  , FixpointState(..)
  , CallFrameContext(..)
  , SomeCallFrameContext(..)
  , ExecutionFeatureContext(..)
  , simpleLoopFixpoint
  ) where

import           Control.Lens
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans.Maybe
import           Data.Foldable
import qualified Data.IntMap as IntMap
import           Data.IORef
import           Data.Kind
import qualified Data.List as List
import           Data.Maybe
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import           Data.Set (Set)
import           GHC.TypeLits (KnownNat)
import           Numeric.Natural (Natural)
import qualified System.IO

import qualified Data.BitVector.Sized as BV
import           Data.Parameterized.Classes
import qualified Data.Parameterized.Context as Ctx
import qualified Data.Parameterized.Map as MapF
import           Data.Parameterized.Map (MapF)
import           Data.Parameterized.NatRepr
import           Data.Parameterized.Some
import           Data.Parameterized.TraversableF
import           Data.Parameterized.TraversableFC

import qualified What4.Config as W4
import qualified What4.Expr.Builder as W4
import qualified What4.Interface as W4
import qualified What4.Solver as W4

import qualified Lang.Crucible.Analysis.Fixpoint.Components as C
import qualified Lang.Crucible.Backend as C
import qualified Lang.Crucible.CFG.Core as C
import qualified Lang.Crucible.FunctionHandle as C
import qualified Lang.Crucible.Panic 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.GlobalState as C
import qualified Lang.Crucible.Simulator.Operations as C
import qualified Lang.Crucible.Simulator.RegMap as C
import qualified Lang.Crucible.Simulator as C

import qualified Lang.Crucible.LLVM.Bytes as C
import qualified Lang.Crucible.LLVM.DataLayout as C
import qualified Lang.Crucible.LLVM.MemModel as C
import qualified Lang.Crucible.LLVM.MemModel.MemLog as C hiding (Mem)
import qualified Lang.Crucible.LLVM.MemModel.Pointer as C
import qualified Lang.Crucible.LLVM.MemModel.Type as C
-- import qualified Lang.Crucible.LLVM.MemModel.Generic as C (writeArrayMem)


-- | When live loop-carried dependencies are discovered as we traverse
--   a loop body, new "widening" variables are introduced to stand in
--   for those locations.  When we introduce such a variable, we
--   capture what value the variable had when we entered the loop (the
--   \"header\" value); this is essentially the initial value of the
--   variable.  We also compute what value the variable should take on
--   its next iteration assuming the loop doesn't exit and executes
--   along its backedge.  This \"body\" value will be computed in
--   terms of the the set of all discovered live variables so far.
--   We know we have reached fixpoint when we don't need to introduce
--   and more fresh widening variables, and the body values for each
--   variable are stable across iterations.
data FixpointEntry sym tp = FixpointEntry
  { forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue :: W4.SymExpr sym tp
  , forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue :: W4.SymExpr sym tp
  }

instance OrdF (W4.SymExpr sym) => OrdF (FixpointEntry sym) where
  compareF :: forall (x :: BaseType) (y :: BaseType).
FixpointEntry sym x -> FixpointEntry sym y -> OrderingF x y
compareF FixpointEntry sym x
x FixpointEntry sym y
y = OrderingF x y -> ((x ~ y) => OrderingF x y) -> OrderingF x y
forall j k (a :: j) (b :: j) (c :: k) (d :: k).
OrderingF a b -> ((a ~ b) => OrderingF c d) -> OrderingF c d
joinOrderingF
    (SymExpr sym x -> SymExpr sym y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
SymExpr sym x -> SymExpr sym y -> OrderingF x y
compareF (FixpointEntry sym x -> SymExpr sym x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue FixpointEntry sym x
x) (FixpointEntry sym y -> SymExpr sym y
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue FixpointEntry sym y
y))
    (SymExpr sym x -> SymExpr sym y -> OrderingF x y
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
SymExpr sym x -> SymExpr sym y -> OrderingF x y
compareF (FixpointEntry sym x -> SymExpr sym x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym x
x) (FixpointEntry sym y -> SymExpr sym y
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym y
y))
instance OrdF (FixpointEntry sym) => W4.TestEquality (FixpointEntry sym) where
  testEquality :: forall (a :: BaseType) (b :: BaseType).
FixpointEntry sym a -> FixpointEntry sym b -> Maybe (a :~: b)
testEquality FixpointEntry sym a
x FixpointEntry sym b
y = OrderingF a b -> Maybe (a :~: b)
forall {k} (x :: k) (y :: k). OrderingF x y -> Maybe (x :~: y)
orderingF_refl (OrderingF a b -> Maybe (a :~: b))
-> OrderingF a b -> Maybe (a :~: b)
forall a b. (a -> b) -> a -> b
$ FixpointEntry sym a -> FixpointEntry sym b -> OrderingF a b
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
FixpointEntry sym x -> FixpointEntry sym y -> OrderingF x y
compareF FixpointEntry sym a
x FixpointEntry sym b
y

data MemLocation sym w = MemLocation
  { forall sym (w :: Nat). MemLocation sym w -> Nat
memLocationBlock :: Natural
  , forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationOffset :: W4.SymBV sym w
  , forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize :: W4.SymBV sym w
  }

instance OrdF (W4.SymExpr sym) => Ord (MemLocation sym w) where
  compare :: MemLocation sym w -> MemLocation sym w -> Ordering
compare MemLocation sym w
x MemLocation sym w
y =
    Nat -> Nat -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MemLocation sym w -> Nat
forall sym (w :: Nat). MemLocation sym w -> Nat
memLocationBlock MemLocation sym w
x) (MemLocation sym w -> Nat
forall sym (w :: Nat). MemLocation sym w -> Nat
memLocationBlock MemLocation sym w
y)
    Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> OrderingF ('BaseBVType w) ('BaseBVType w) -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (SymExpr sym ('BaseBVType w)
-> SymExpr sym ('BaseBVType w)
-> OrderingF ('BaseBVType w) ('BaseBVType w)
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
SymExpr sym x -> SymExpr sym y -> OrderingF x y
compareF (MemLocation sym w -> SymExpr sym ('BaseBVType w)
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationOffset MemLocation sym w
x) (MemLocation sym w -> SymExpr sym ('BaseBVType w)
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationOffset MemLocation sym w
y))
    Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> OrderingF ('BaseBVType w) ('BaseBVType w) -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (SymExpr sym ('BaseBVType w)
-> SymExpr sym ('BaseBVType w)
-> OrderingF ('BaseBVType w) ('BaseBVType w)
forall k (ktp :: k -> Type) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
forall (x :: BaseType) (y :: BaseType).
SymExpr sym x -> SymExpr sym y -> OrderingF x y
compareF (MemLocation sym w -> SymExpr sym ('BaseBVType w)
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym w
x) (MemLocation sym w -> SymExpr sym ('BaseBVType w)
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym w
y))
instance OrdF (W4.SymExpr sym) => Eq (MemLocation sym w) where
  MemLocation sym w
x == :: MemLocation sym w -> MemLocation sym w -> Bool
== MemLocation sym w
y = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== MemLocation sym w -> MemLocation sym w -> Ordering
forall a. Ord a => a -> a -> Ordering
compare MemLocation sym w
x MemLocation sym w
y

data MemFixpointEntry sym wptr where
  MemStoreFixpointEntry ::
    (1 <= w) =>
    W4.SymBV sym w {- ^ bitvector join variable -} ->
    C.StorageType ->
    MemFixpointEntry sym wptr
  MemArrayFixpointEntry ::
    W4.SymArray sym (C.SingleCtx (W4.BaseBVType wptr)) (W4.BaseBVType 8) {- ^ array join variable -} ->
    W4.SymBV sym wptr {- ^ length of the allocation -} ->
    MemFixpointEntry sym wptr


-- | This datatype captures the state machine that progresses as we
--   attempt to compute a loop invariant for a simple structured loop.
data FixpointState sym wptr blocks args
    -- | We have not yet encoundered the loop head
  = BeforeFixpoint

    -- | We have encountered the loop head at least once, and are in the process
    --   of converging to an inductive representation of the live variables
    --   in the loop.
  | ComputeFixpoint (FixpointRecord sym wptr blocks args)

    -- | We have found an inductively-strong representation of the live variables
    --   of the loop, and have discovered the loop index structure controling the
    --   execution of the loop. We are now executing the loop once more to compute
    --   verification conditions for executions that reamain in the loop.
  | CheckFixpoint
      (FixpointRecord sym wptr blocks args)
      (W4.SomeSymFn sym) -- ^ function that represents the loop invariant
      (Some (Ctx.Assignment (W4.SymExpr sym))) -- ^ arguments to the loop invariant
      (W4.Pred sym) -- ^ predicate that represents the loop condition

    -- | Finally, we stitch everything we have found together into the rest of the program.
    --   Starting from the loop header one final time, we now force execution to exit the loop
    --   and continue into the rest of the program.
  | AfterFixpoint
      (FixpointRecord sym wptr blocks args)

-- | Data about the loop that we incrementally compute as we approach fixpoint.
data FixpointRecord sym wptr blocks args = FixpointRecord
  {
    -- | Block identifier of the head of the loop
    forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> BlockID blocks args
fixpointBlockId :: C.BlockID blocks args

    -- | identifier for the currently-active assumption frame related to this fixpoint computation
  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> FrameIdentifier
fixpointAssumptionFrameIdentifier :: C.FrameIdentifier

    -- | Map from introduced widening variables to prestate value before the loop starts,
    --   and to the value computed in a single loop iteration, assuming we return to the
    --   loop header. These variables may appear only in either registers or memory.
  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution :: MapF (W4.SymExpr sym) (FixpointEntry sym)

    -- | Prestate values of the Crucible registers when the loop header is first encountered.
  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> RegMap sym args
fixpointRegMap :: C.RegMap sym args

    -- | Triples are (blockId, offset, size) to bitvector-typed entries ( bitvector only/not pointers )
  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution :: Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)

  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution :: MapF (W4.SymExpr sym) (W4.SymExpr sym)

    -- | The loop index variable
  , forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex :: W4.SymBV sym wptr
  }


data CallFrameContext sym wptr ext init ret blocks = CallFrameContext
  { forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
callFrameContextFixpointStates :: MapF (C.BlockID blocks) (FixpointState sym wptr blocks)
  , forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> [Some (BlockID blocks)]
callFrameContextLoopHeaders :: [C.Some (C.BlockID blocks)]
  , forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> CFG ext blocks init ret
callFrameContextCFG :: C.CFG ext blocks init ret
  , forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
callFrameContextParentLoop :: Map (C.Some (C.BlockID blocks)) (C.Some (C.BlockID blocks))
  , forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> Set (Some (BlockID blocks))
callFrameContextLoopHeaderBlockIds :: Set (C.Some (C.BlockID blocks))
  }

data CallFrameHandle init ret blocks = CallFrameHandle (C.FnHandle init ret) (Ctx.Assignment (Ctx.Assignment C.TypeRepr) blocks)
  deriving (CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
(CallFrameHandle init ret blocks
 -> CallFrameHandle init ret blocks -> Bool)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks -> Bool)
-> Eq (CallFrameHandle init ret blocks)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$c== :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
== :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$c/= :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
/= :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
Eq, Eq (CallFrameHandle init ret blocks)
Eq (CallFrameHandle init ret blocks) =>
(CallFrameHandle init ret blocks
 -> CallFrameHandle init ret blocks -> Ordering)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks -> Bool)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks -> Bool)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks -> Bool)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks -> Bool)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks)
-> (CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks
    -> CallFrameHandle init ret blocks)
-> Ord (CallFrameHandle init ret blocks)
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Ordering
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
Eq (CallFrameHandle init ret blocks)
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Ordering
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
$ccompare :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Ordering
compare :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Ordering
$c< :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
< :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$c<= :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
<= :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$c> :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
> :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$c>= :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
>= :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks -> Bool
$cmax :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
max :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
$cmin :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
min :: CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
-> CallFrameHandle init ret blocks
Ord, Int -> CallFrameHandle init ret blocks -> ShowS
[CallFrameHandle init ret blocks] -> ShowS
CallFrameHandle init ret blocks -> String
(Int -> CallFrameHandle init ret blocks -> ShowS)
-> (CallFrameHandle init ret blocks -> String)
-> ([CallFrameHandle init ret blocks] -> ShowS)
-> Show (CallFrameHandle init ret blocks)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
Int -> CallFrameHandle init ret blocks -> ShowS
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
[CallFrameHandle init ret blocks] -> ShowS
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks -> String
$cshowsPrec :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
Int -> CallFrameHandle init ret blocks -> ShowS
showsPrec :: Int -> CallFrameHandle init ret blocks -> ShowS
$cshow :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
CallFrameHandle init ret blocks -> String
show :: CallFrameHandle init ret blocks -> String
$cshowList :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
[CallFrameHandle init ret blocks] -> ShowS
showList :: [CallFrameHandle init ret blocks] -> ShowS
Show)

data SomeCallFrameContext sym wptr ext init ret =
  forall blocks . SomeCallFrameContext (CallFrameContext sym wptr ext init ret blocks)

unwrapSomeCallFrameContext ::
  Ctx.Assignment (Ctx.Assignment C.TypeRepr) blocks ->
  SomeCallFrameContext sym wptr ext init ret ->
  CallFrameContext sym wptr ext init ret blocks
unwrapSomeCallFrameContext :: forall (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
Assignment (Assignment TypeRepr) blocks
-> SomeCallFrameContext sym wptr ext init ret
-> CallFrameContext sym wptr ext init ret blocks
unwrapSomeCallFrameContext Assignment (Assignment TypeRepr) blocks
blocks_repr (SomeCallFrameContext CallFrameContext sym wptr ext init ret blocks
ctx) =
  case Assignment (Assignment TypeRepr) blocks
-> Assignment (Assignment TypeRepr) blocks
-> Maybe (blocks :~: blocks)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Ctx (Ctx CrucibleType)) (b :: Ctx (Ctx CrucibleType)).
Assignment (Assignment TypeRepr) a
-> Assignment (Assignment TypeRepr) b -> Maybe (a :~: b)
W4.testEquality Assignment (Assignment TypeRepr) blocks
blocks_repr ((forall (x :: Ctx CrucibleType).
 Block ext blocks ret x -> Assignment TypeRepr x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment (Block ext blocks ret) x
   -> Assignment (Assignment TypeRepr) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: Ctx CrucibleType -> Type)
       (g :: Ctx CrucibleType -> Type).
(forall (x :: Ctx CrucibleType). f x -> g x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment f x -> Assignment g x
fmapFC Block ext blocks ret x -> CtxRepr x
forall ext (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType)
       (ctx :: Ctx CrucibleType).
Block ext blocks ret ctx -> CtxRepr ctx
forall (x :: Ctx CrucibleType).
Block ext blocks ret x -> Assignment TypeRepr x
C.blockInputs (Assignment (Block ext blocks ret) blocks
 -> Assignment (Assignment TypeRepr) blocks)
-> Assignment (Block ext blocks ret) blocks
-> Assignment (Assignment TypeRepr) blocks
forall a b. (a -> b) -> a -> b
$ CFG ext blocks init ret -> Assignment (Block ext blocks ret) blocks
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> BlockMap ext blocks ret
C.cfgBlockMap (CFG ext blocks init ret
 -> Assignment (Block ext blocks ret) blocks)
-> CFG ext blocks init ret
-> Assignment (Block ext blocks ret) blocks
forall a b. (a -> b) -> a -> b
$ CallFrameContext sym wptr ext init ret blocks
-> CFG ext blocks init ret
forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> CFG ext blocks init ret
callFrameContextCFG CallFrameContext sym wptr ext init ret blocks
ctx) of
    Just blocks :~: blocks
Refl -> CallFrameContext sym wptr ext init ret blocks
CallFrameContext sym wptr ext init ret blocks
ctx
    Maybe (blocks :~: blocks)
Nothing -> String -> [String] -> CallFrameContext sym wptr ext init ret blocks
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.unwrapSomeCallFrameContext" [String
"type mismatch"]

data ExecutionFeatureContext sym wptr ext = ExecutionFeatureContext
  { forall sym (wptr :: Nat) ext.
ExecutionFeatureContext sym wptr ext
-> FnHandleMap (SomeCallFrameContext sym wptr ext)
executionFeatureContextFixpointStates :: C.FnHandleMap (SomeCallFrameContext sym wptr ext)
  , forall sym (wptr :: Nat) ext.
ExecutionFeatureContext sym wptr ext -> [SomeSymFn sym]
executionFeatureContextInvPreds :: [W4.SomeSymFn sym]
  , forall sym (wptr :: Nat) ext.
ExecutionFeatureContext sym wptr ext -> [Pred sym]
executionFeatureContextLoopFunEquivConds :: [W4.Pred sym]
  }

callFrameContextLookup ::
  CallFrameHandle init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup (CallFrameHandle FnHandle init ret
hdl Assignment (Assignment TypeRepr) blocks
blocks_repr) ExecutionFeatureContext sym wptr ext
ctx =
  Assignment (Assignment TypeRepr) blocks
-> SomeCallFrameContext sym wptr ext init ret
-> CallFrameContext sym wptr ext init ret blocks
forall (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
Assignment (Assignment TypeRepr) blocks
-> SomeCallFrameContext sym wptr ext init ret
-> CallFrameContext sym wptr ext init ret blocks
unwrapSomeCallFrameContext Assignment (Assignment TypeRepr) blocks
blocks_repr (SomeCallFrameContext sym wptr ext init ret
 -> CallFrameContext sym wptr ext init ret blocks)
-> SomeCallFrameContext sym wptr ext init ret
-> CallFrameContext sym wptr ext init ret blocks
forall a b. (a -> b) -> a -> b
$
    SomeCallFrameContext sym wptr ext init ret
-> Maybe (SomeCallFrameContext sym wptr ext init ret)
-> SomeCallFrameContext sym wptr ext init ret
forall a. a -> Maybe a -> a
fromMaybe (String -> [String] -> SomeCallFrameContext sym wptr ext init ret
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.callFrameContextLookup" [String
"missing call frame context", FnHandle init ret -> String
forall a. Show a => a -> String
show FnHandle init ret
hdl]) (Maybe (SomeCallFrameContext sym wptr ext init ret)
 -> SomeCallFrameContext sym wptr ext init ret)
-> Maybe (SomeCallFrameContext sym wptr ext init ret)
-> SomeCallFrameContext sym wptr ext init ret
forall a b. (a -> b) -> a -> b
$
      FnHandle init ret
-> FnHandleMap (SomeCallFrameContext sym wptr ext)
-> Maybe (SomeCallFrameContext sym wptr ext init ret)
forall (args :: Ctx CrucibleType) (ret :: CrucibleType)
       (f :: Ctx CrucibleType -> CrucibleType -> Type).
FnHandle args ret -> FnHandleMap f -> Maybe (f args ret)
C.lookupHandleMap FnHandle init ret
hdl (ExecutionFeatureContext sym wptr ext
-> FnHandleMap (SomeCallFrameContext sym wptr ext)
forall sym (wptr :: Nat) ext.
ExecutionFeatureContext sym wptr ext
-> FnHandleMap (SomeCallFrameContext sym wptr ext)
executionFeatureContextFixpointStates ExecutionFeatureContext sym wptr ext
ctx)

callFrameContextUpdate ::
  CallFrameHandle init ret blocks ->
  (CallFrameContext sym wptr ext init ret blocks -> CallFrameContext sym wptr ext init ret blocks) ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
callFrameContextUpdate :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextUpdate (CallFrameHandle FnHandle init ret
hdl Assignment (Assignment TypeRepr) blocks
blocks_repr) CallFrameContext sym wptr ext init ret blocks
-> CallFrameContext sym wptr ext init ret blocks
f ExecutionFeatureContext sym wptr ext
ctx =
  ExecutionFeatureContext sym wptr ext
ctx
    { executionFeatureContextFixpointStates = C.updateHandleMap
        (SomeCallFrameContext . f . unwrapSomeCallFrameContext blocks_repr)
        hdl
        (executionFeatureContextFixpointStates ctx)
    }

callFrameContextLookup' ::
  CallFrameHandle init ret blocks ->
  C.BlockID blocks args ->
  ExecutionFeatureContext sym wptr ext ->
  Maybe (FixpointState sym wptr blocks args)
callFrameContextLookup' :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> ExecutionFeatureContext sym wptr ext
-> Maybe (FixpointState sym wptr blocks args)
callFrameContextLookup' CallFrameHandle init ret blocks
hdl BlockID blocks args
bid ExecutionFeatureContext sym wptr ext
ctx =
  BlockID blocks args
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
-> Maybe (FixpointState sym wptr blocks args)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup BlockID blocks args
bid (MapF (BlockID blocks) (FixpointState sym wptr blocks)
 -> Maybe (FixpointState sym wptr blocks args))
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
-> Maybe (FixpointState sym wptr blocks args)
forall a b. (a -> b) -> a -> b
$ CallFrameContext sym wptr ext init ret blocks
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
callFrameContextFixpointStates (CallFrameContext sym wptr ext init ret blocks
 -> MapF (BlockID blocks) (FixpointState sym wptr blocks))
-> CallFrameContext sym wptr ext init ret blocks
-> MapF (BlockID blocks) (FixpointState sym wptr blocks)
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup CallFrameHandle init ret blocks
hdl ExecutionFeatureContext sym wptr ext
ctx

callFrameContextInsert ::
  CallFrameHandle init ret blocks ->
  C.BlockID blocks args ->
  FixpointState sym wptr blocks args ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
callFrameContextInsert :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
hdl BlockID blocks args
bid FixpointState sym wptr blocks args
fs =
  CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextUpdate CallFrameHandle init ret blocks
hdl ((CallFrameContext sym wptr ext init ret blocks
  -> CallFrameContext sym wptr ext init ret blocks)
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
    \CallFrameContext sym wptr ext init ret blocks
ctx -> CallFrameContext sym wptr ext init ret blocks
ctx { callFrameContextFixpointStates = MapF.insert bid fs (callFrameContextFixpointStates ctx) }

callFrameContextPush ::
  CallFrameHandle init ret blocks ->
  C.Some (C.BlockID blocks) ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
callFrameContextPush :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> Some (BlockID blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextPush CallFrameHandle init ret blocks
hdl Some (BlockID blocks)
bid =
  CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextUpdate CallFrameHandle init ret blocks
hdl ((CallFrameContext sym wptr ext init ret blocks
  -> CallFrameContext sym wptr ext init ret blocks)
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
    \CallFrameContext sym wptr ext init ret blocks
ctx -> CallFrameContext sym wptr ext init ret blocks
ctx { callFrameContextLoopHeaders = bid : callFrameContextLoopHeaders ctx }

-- | Precondition: the context's 'callFrameContextLoopHeaders' should be
-- non-empty.
callFrameContextPop ::
  CallFrameHandle init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
callFrameContextPop :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextPop  CallFrameHandle init ret blocks
hdl =
  CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextUpdate CallFrameHandle init ret blocks
hdl ((CallFrameContext sym wptr ext init ret blocks
  -> CallFrameContext sym wptr ext init ret blocks)
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> (CallFrameContext sym wptr ext init ret blocks
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
    \CallFrameContext sym wptr ext init ret blocks
ctx -> CallFrameContext sym wptr ext init ret blocks
ctx { callFrameContextLoopHeaders =
                    case callFrameContextLoopHeaders ctx of
                      Some (BlockID blocks)
_:[Some (BlockID blocks)]
hdrs -> [Some (BlockID blocks)]
hdrs
                      [] -> String -> [String] -> [Some (BlockID blocks)]
forall a. HasCallStack => String -> [String] -> a
C.panic String
"callFrameContextPop"
                                    [String
"Empty callFrameContextLoopHeaders"] }

callFrameContextPeek ::
  CallFrameHandle init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  Maybe (C.Some (C.BlockID blocks))
callFrameContextPeek :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Maybe (Some (BlockID blocks))
callFrameContextPeek CallFrameHandle init ret blocks
hdl ExecutionFeatureContext sym wptr ext
ctx =
  [Some (BlockID blocks)] -> Maybe (Some (BlockID blocks))
forall a. [a] -> Maybe a
listToMaybe ([Some (BlockID blocks)] -> Maybe (Some (BlockID blocks)))
-> [Some (BlockID blocks)] -> Maybe (Some (BlockID blocks))
forall a b. (a -> b) -> a -> b
$ CallFrameContext sym wptr ext init ret blocks
-> [Some (BlockID blocks)]
forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> [Some (BlockID blocks)]
callFrameContextLoopHeaders (CallFrameContext sym wptr ext init ret blocks
 -> [Some (BlockID blocks)])
-> CallFrameContext sym wptr ext init ret blocks
-> [Some (BlockID blocks)]
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup CallFrameHandle init ret blocks
hdl ExecutionFeatureContext sym wptr ext
ctx

callFrameContextLoopHeaderBlockIds' ::
  CallFrameHandle init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  Set (C.Some (C.BlockID blocks))
callFrameContextLoopHeaderBlockIds' :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Set (Some (BlockID blocks))
callFrameContextLoopHeaderBlockIds' CallFrameHandle init ret blocks
hdl =
  CallFrameContext sym wptr ext init ret blocks
-> Set (Some (BlockID blocks))
forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> Set (Some (BlockID blocks))
callFrameContextLoopHeaderBlockIds (CallFrameContext sym wptr ext init ret blocks
 -> Set (Some (BlockID blocks)))
-> (ExecutionFeatureContext sym wptr ext
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> Set (Some (BlockID blocks))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup CallFrameHandle init ret blocks
hdl

callFrameContextParentLoop' ::
  CallFrameHandle init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  Map (C.Some (C.BlockID blocks)) (C.Some (C.BlockID blocks))
callFrameContextParentLoop' :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
callFrameContextParentLoop' CallFrameHandle init ret blocks
hdl =
  CallFrameContext sym wptr ext init ret blocks
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
forall sym (wptr :: Nat) ext (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType)).
CallFrameContext sym wptr ext init ret blocks
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
callFrameContextParentLoop (CallFrameContext sym wptr ext init ret blocks
 -> Map (Some (BlockID blocks)) (Some (BlockID blocks)))
-> (ExecutionFeatureContext sym wptr ext
    -> CallFrameContext sym wptr ext init ret blocks)
-> ExecutionFeatureContext sym wptr ext
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> CallFrameContext sym wptr ext init ret blocks
callFrameContextLookup CallFrameHandle init ret blocks
hdl

executionFeatureContextAddCallFrameContext ::
  CallFrameHandle init ret blocks ->
  CallFrameContext sym wptr ext init ret blocks ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
executionFeatureContextAddCallFrameContext :: forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> CallFrameContext sym wptr ext init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddCallFrameContext (CallFrameHandle FnHandle init ret
hdl Assignment (Assignment TypeRepr) blocks
_blocks_repr) CallFrameContext sym wptr ext init ret blocks
ctx ExecutionFeatureContext sym wptr ext
context =
  ExecutionFeatureContext sym wptr ext
context
    { executionFeatureContextFixpointStates =
        C.insertHandleMap hdl (SomeCallFrameContext ctx) (executionFeatureContextFixpointStates context)
    }

executionFeatureContextAddInvPred ::
  W4.SomeSymFn sym ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
executionFeatureContextAddInvPred :: forall sym (wptr :: Nat) ext.
SomeSymFn sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddInvPred SomeSymFn sym
inv_pred ExecutionFeatureContext sym wptr ext
context =
  ExecutionFeatureContext sym wptr ext
context { executionFeatureContextInvPreds = inv_pred : executionFeatureContextInvPreds context }

executionFeatureContextAddLoopFunEquivCond ::
  W4.Pred sym ->
  ExecutionFeatureContext sym wptr ext ->
  ExecutionFeatureContext sym wptr ext
executionFeatureContextAddLoopFunEquivCond :: forall sym (wptr :: Nat) ext.
Pred sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddLoopFunEquivCond Pred sym
cond ExecutionFeatureContext sym wptr ext
context =
  ExecutionFeatureContext sym wptr ext
context { executionFeatureContextLoopFunEquivConds = cond : executionFeatureContextLoopFunEquivConds context }


newtype FixpointMonad sym a =
  FixpointMonad (StateT (MapF (W4.SymExpr sym) (FixpointEntry sym)) IO a)
  deriving ((forall a b.
 (a -> b) -> FixpointMonad sym a -> FixpointMonad sym b)
-> (forall a b. a -> FixpointMonad sym b -> FixpointMonad sym a)
-> Functor (FixpointMonad sym)
forall a b. a -> FixpointMonad sym b -> FixpointMonad sym a
forall a b. (a -> b) -> FixpointMonad sym a -> FixpointMonad sym b
forall sym a b. a -> FixpointMonad sym b -> FixpointMonad sym a
forall sym a b.
(a -> b) -> FixpointMonad sym a -> FixpointMonad sym b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall sym a b.
(a -> b) -> FixpointMonad sym a -> FixpointMonad sym b
fmap :: forall a b. (a -> b) -> FixpointMonad sym a -> FixpointMonad sym b
$c<$ :: forall sym a b. a -> FixpointMonad sym b -> FixpointMonad sym a
<$ :: forall a b. a -> FixpointMonad sym b -> FixpointMonad sym a
Functor, Functor (FixpointMonad sym)
Functor (FixpointMonad sym) =>
(forall a. a -> FixpointMonad sym a)
-> (forall a b.
    FixpointMonad sym (a -> b)
    -> FixpointMonad sym a -> FixpointMonad sym b)
-> (forall a b c.
    (a -> b -> c)
    -> FixpointMonad sym a
    -> FixpointMonad sym b
    -> FixpointMonad sym c)
-> (forall a b.
    FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b)
-> (forall a b.
    FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym a)
-> Applicative (FixpointMonad sym)
forall sym. Functor (FixpointMonad sym)
forall a. a -> FixpointMonad sym a
forall sym a. a -> FixpointMonad sym a
forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym a
forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
forall a b.
FixpointMonad sym (a -> b)
-> FixpointMonad sym a -> FixpointMonad sym b
forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym a
forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
forall sym a b.
FixpointMonad sym (a -> b)
-> FixpointMonad sym a -> FixpointMonad sym b
forall a b c.
(a -> b -> c)
-> FixpointMonad sym a
-> FixpointMonad sym b
-> FixpointMonad sym c
forall sym a b c.
(a -> b -> c)
-> FixpointMonad sym a
-> FixpointMonad sym b
-> FixpointMonad sym c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall sym a. a -> FixpointMonad sym a
pure :: forall a. a -> FixpointMonad sym a
$c<*> :: forall sym a b.
FixpointMonad sym (a -> b)
-> FixpointMonad sym a -> FixpointMonad sym b
<*> :: forall a b.
FixpointMonad sym (a -> b)
-> FixpointMonad sym a -> FixpointMonad sym b
$cliftA2 :: forall sym a b c.
(a -> b -> c)
-> FixpointMonad sym a
-> FixpointMonad sym b
-> FixpointMonad sym c
liftA2 :: forall a b c.
(a -> b -> c)
-> FixpointMonad sym a
-> FixpointMonad sym b
-> FixpointMonad sym c
$c*> :: forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
*> :: forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
$c<* :: forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym a
<* :: forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym a
Applicative, Applicative (FixpointMonad sym)
Applicative (FixpointMonad sym) =>
(forall a b.
 FixpointMonad sym a
 -> (a -> FixpointMonad sym b) -> FixpointMonad sym b)
-> (forall a b.
    FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b)
-> (forall a. a -> FixpointMonad sym a)
-> Monad (FixpointMonad sym)
forall sym. Applicative (FixpointMonad sym)
forall a. a -> FixpointMonad sym a
forall sym a. a -> FixpointMonad sym a
forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
forall a b.
FixpointMonad sym a
-> (a -> FixpointMonad sym b) -> FixpointMonad sym b
forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
forall sym a b.
FixpointMonad sym a
-> (a -> FixpointMonad sym b) -> FixpointMonad sym b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall sym a b.
FixpointMonad sym a
-> (a -> FixpointMonad sym b) -> FixpointMonad sym b
>>= :: forall a b.
FixpointMonad sym a
-> (a -> FixpointMonad sym b) -> FixpointMonad sym b
$c>> :: forall sym a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
>> :: forall a b.
FixpointMonad sym a -> FixpointMonad sym b -> FixpointMonad sym b
$creturn :: forall sym a. a -> FixpointMonad sym a
return :: forall a. a -> FixpointMonad sym a
Monad, Monad (FixpointMonad sym)
Monad (FixpointMonad sym) =>
(forall a. IO a -> FixpointMonad sym a)
-> MonadIO (FixpointMonad sym)
forall sym. Monad (FixpointMonad sym)
forall a. IO a -> FixpointMonad sym a
forall sym a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall sym a. IO a -> FixpointMonad sym a
liftIO :: forall a. IO a -> FixpointMonad sym a
MonadIO, Monad (FixpointMonad sym)
Monad (FixpointMonad sym) =>
(forall a. String -> FixpointMonad sym a)
-> MonadFail (FixpointMonad sym)
forall sym. Monad (FixpointMonad sym)
forall a. String -> FixpointMonad sym a
forall sym a. String -> FixpointMonad sym a
forall (m :: Type -> Type).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall sym a. String -> FixpointMonad sym a
fail :: forall a. String -> FixpointMonad sym a
MonadFail)

deriving instance s ~ MapF (W4.SymExpr sym) (FixpointEntry sym) => MonadState s (FixpointMonad sym)

runFixpointMonad ::
  FixpointMonad sym a ->
  MapF (W4.SymExpr sym) (FixpointEntry sym) ->
  IO (a, MapF (W4.SymExpr sym) (FixpointEntry sym))
runFixpointMonad :: forall sym a.
FixpointMonad sym a
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO (a, MapF (SymExpr sym) (FixpointEntry sym))
runFixpointMonad (FixpointMonad StateT (MapF (SymExpr sym) (FixpointEntry sym)) IO a
m) = StateT (MapF (SymExpr sym) (FixpointEntry sym)) IO a
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO (a, MapF (SymExpr sym) (FixpointEntry sym))
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT StateT (MapF (SymExpr sym) (FixpointEntry sym)) IO a
m


joinRegEntries ::
  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>
  sym ->
  Ctx.Assignment (C.RegEntry sym) ctx ->
  Ctx.Assignment (C.RegEntry sym) ctx ->
  FixpointMonad sym (Ctx.Assignment (C.RegEntry sym) ctx)
joinRegEntries :: forall sym (ctx :: Ctx CrucibleType).
(?logMessage::String -> IO (), IsSymInterface sym) =>
sym
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
joinRegEntries sym
sym = (forall (x :: CrucibleType).
 RegEntry sym x
 -> RegEntry sym x -> FixpointMonad sym (RegEntry sym x))
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
forall {k} (m :: Type -> Type) (f :: k -> Type) (g :: k -> Type)
       (h :: k -> Type) (a :: Ctx k).
Applicative m =>
(forall (x :: k). f x -> g x -> m (h x))
-> Assignment f a -> Assignment g a -> m (Assignment h a)
Ctx.zipWithM (sym
-> RegEntry sym x
-> RegEntry sym x
-> FixpointMonad sym (RegEntry sym x)
forall sym (tp :: CrucibleType).
(?logMessage::String -> IO (), IsSymInterface sym) =>
sym
-> RegEntry sym tp
-> RegEntry sym tp
-> FixpointMonad sym (RegEntry sym tp)
joinRegEntry sym
sym)

joinRegEntry ::
  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>
  sym ->
  C.RegEntry sym tp ->
  C.RegEntry sym tp ->
  FixpointMonad sym (C.RegEntry sym tp)
joinRegEntry :: forall sym (tp :: CrucibleType).
(?logMessage::String -> IO (), IsSymInterface sym) =>
sym
-> RegEntry sym tp
-> RegEntry sym tp
-> FixpointMonad sym (RegEntry sym tp)
joinRegEntry sym
sym RegEntry sym tp
left RegEntry sym tp
right = case RegEntry sym tp -> TypeRepr tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> TypeRepr tp
C.regType RegEntry sym tp
left of
  C.LLVMPointerRepr NatRepr w
w

      -- special handling for "don't care" registers coming from Macaw
    | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"cmacaw_reg" (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SymNat sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => SymNat sym -> Doc ann
W4.printSymNat (SymNat sym -> Doc Any) -> SymNat sym -> Doc Any
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left))
    , String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"cmacaw_reg" (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SymExpr sym (BaseBVType w) -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym (BaseBVType w) -> Doc Any)
-> SymExpr sym (BaseBVType w) -> Doc Any
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) -> do
      IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: cmacaw_reg"
      RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return RegEntry sym tp
left

    | LLVMPtr sym w -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left) SymNat sym -> SymNat sym -> Bool
forall a. Eq a => a -> a -> Bool
== LLVMPtr sym w -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right) -> do
      IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr"
      MapF (SymExpr sym) (FixpointEntry sym)
subst <- FixpointMonad sym (MapF (SymExpr sym) (FixpointEntry sym))
forall s (m :: Type -> Type). MonadState s m => m s
get
      if Maybe (BaseBVType w :~: BaseBVType w) -> Bool
forall a. Maybe a -> Bool
isJust (SymExpr sym (BaseBVType w)
-> SymExpr sym (BaseBVType w)
-> Maybe (BaseBVType w :~: BaseBVType w)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
SymExpr sym a -> SymExpr sym b -> Maybe (a :~: b)
W4.testEquality (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right)))
      then do
        IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: left == right"
        RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return RegEntry sym tp
left
      else case SymExpr sym (BaseBVType w)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> Maybe (FixpointEntry sym (BaseBVType w))
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) MapF (SymExpr sym) (FixpointEntry sym)
subst of
        Just FixpointEntry sym (BaseBVType w)
join_entry -> do
          IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Just: "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymExpr sym (BaseBVType w) -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym (BaseBVType w) -> Doc Any)
-> SymExpr sym (BaseBVType w) -> Doc Any
forall a b. (a -> b) -> a -> b
$ FixpointEntry sym (BaseBVType w) -> SymExpr sym (BaseBVType w)
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym (BaseBVType w)
join_entry)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymExpr sym (BaseBVType w) -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym (BaseBVType w) -> Doc Any)
-> SymExpr sym (BaseBVType w) -> Doc Any
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right))
          MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ())
-> MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ SymExpr sym (BaseBVType w)
-> FixpointEntry sym (BaseBVType w)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert
            (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left))
            (FixpointEntry sym (BaseBVType w)
join_entry { bodyValue = C.llvmPointerOffset (C.regValue right) })
            MapF (SymExpr sym) (FixpointEntry sym)
subst
          RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return RegEntry sym tp
left
        Maybe (FixpointEntry sym (BaseBVType w))
Nothing -> do
          IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Nothing"
          SymExpr sym (BaseBVType w)
join_variable <- IO (SymExpr sym (BaseBVType w))
-> FixpointMonad sym (SymExpr sym (BaseBVType w))
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym (BaseBVType w))
 -> FixpointMonad sym (SymExpr sym (BaseBVType w)))
-> IO (SymExpr sym (BaseBVType w))
-> FixpointMonad sym (SymExpr sym (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ sym
-> SolverSymbol
-> BaseTypeRepr (BaseBVType w)
-> IO (SymExpr sym (BaseBVType w))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
W4.freshConstant sym
sym (String -> SolverSymbol
W4.safeSymbol String
"reg_join_var") (NatRepr w -> BaseTypeRepr (BaseBVType w)
forall (w :: Nat).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
W4.BaseBVRepr NatRepr w
w)
          let join_entry :: FixpointEntry sym (BaseBVType w)
join_entry = FixpointEntry
                { headerValue :: SymExpr sym (BaseBVType w)
headerValue = LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)
                , bodyValue :: SymExpr sym (BaseBVType w)
bodyValue = LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right)
                }
          MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ())
-> MapF (SymExpr sym) (FixpointEntry sym) -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ SymExpr sym (BaseBVType w)
-> FixpointEntry sym (BaseBVType w)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert SymExpr sym (BaseBVType w)
join_variable FixpointEntry sym (BaseBVType w)
join_entry MapF (SymExpr sym) (FixpointEntry sym)
subst
          RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp))
-> RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a b. (a -> b) -> a -> b
$ TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (NatRepr w -> TypeRepr tp
forall (ty :: CrucibleType) (w :: Nat).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
C.LLVMPointerRepr NatRepr w
w) (RegValue sym tp -> RegEntry sym tp)
-> RegValue sym tp -> RegEntry sym tp
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymExpr sym (BaseBVType w) -> LLVMPointer sym w
forall sym (w :: Nat).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
C.LLVMPointer (LLVMPtr sym w -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) SymExpr sym (BaseBVType w)
join_variable
    | Just{} <- SymExpr sym (BaseBVType w) -> Maybe (ConcreteVal (BaseBVType w))
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> Maybe (ConcreteVal tp)
W4.asConcrete (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) -> do
      RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp))
-> RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a b. (a -> b) -> a -> b
$ TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (NatRepr w -> TypeRepr tp
forall (ty :: CrucibleType) (w :: Nat).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
C.LLVMPointerRepr NatRepr w
w) (RegValue sym tp -> RegEntry sym tp)
-> RegValue sym tp -> RegEntry sym tp
forall a b. (a -> b) -> a -> b
$ SymNat sym -> SymExpr sym (BaseBVType w) -> LLVMPointer sym w
forall sym (w :: Nat).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
C.LLVMPointer (LLVMPtr sym w -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)) (LLVMPtr sym w -> SymExpr sym (BaseBVType w)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left))
    | Bool
otherwise ->
      String -> FixpointMonad sym (RegEntry sym tp)
forall a. String -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> FixpointMonad sym (RegEntry sym tp))
-> String -> FixpointMonad sym (RegEntry sym tp)
forall a b. (a -> b) -> a -> b
$
        String
"SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: unsupported pointer base join: "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (LLVMPtr sym w -> Doc Any
forall sym (wptr :: Nat) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
C.ppPtr (LLVMPtr sym w -> Doc Any) -> LLVMPtr sym w -> Doc Any
forall a b. (a -> b) -> a -> b
$ RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" \\/ "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (LLVMPtr sym w -> Doc Any
forall sym (wptr :: Nat) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
C.ppPtr (LLVMPtr sym w -> Doc Any) -> LLVMPtr sym w -> Doc Any
forall a b. (a -> b) -> a -> b
$ RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right)

  TypeRepr tp
C.BoolRepr
    | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"cmacaw" (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SymExpr sym BaseBoolType -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym BaseBoolType -> Doc Any)
-> SymExpr sym BaseBoolType -> Doc Any
forall a b. (a -> b) -> a -> b
$ RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left) -> do
      IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: cmacaw_reg"
      RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return RegEntry sym tp
left
    | Bool
otherwise -> do
      IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"SimpleLoopFixpoint.joinRegEntry: BoolRepr:"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymExpr sym BaseBoolType -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym BaseBoolType -> Doc Any)
-> SymExpr sym BaseBoolType -> Doc Any
forall a b. (a -> b) -> a -> b
$ RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" \\/ "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymExpr sym BaseBoolType -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr sym BaseBoolType -> Doc Any)
-> SymExpr sym BaseBoolType -> Doc Any
forall a b. (a -> b) -> a -> b
$ RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right)
      SymExpr sym BaseBoolType
join_varaible <- IO (SymExpr sym BaseBoolType)
-> FixpointMonad sym (SymExpr sym BaseBoolType)
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymExpr sym BaseBoolType)
 -> FixpointMonad sym (SymExpr sym BaseBoolType))
-> IO (SymExpr sym BaseBoolType)
-> FixpointMonad sym (SymExpr sym BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym
-> SolverSymbol
-> BaseTypeRepr BaseBoolType
-> IO (SymExpr sym BaseBoolType)
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
W4.freshConstant sym
sym (String -> SolverSymbol
W4.safeSymbol String
"macaw_reg") BaseTypeRepr BaseBoolType
W4.BaseBoolRepr
      RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a. a -> FixpointMonad sym a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp))
-> RegEntry sym tp -> FixpointMonad sym (RegEntry sym tp)
forall a b. (a -> b) -> a -> b
$ TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry TypeRepr tp
TypeRepr ('BaseToType BaseBoolType)
C.BoolRepr RegValue sym tp
SymExpr sym BaseBoolType
join_varaible

  C.StructRepr CtxRepr ctx
field_types -> do
    IO () -> FixpointMonad sym ()
forall a. IO a -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> FixpointMonad sym ()) -> IO () -> FixpointMonad sym ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint.joinRegEntry: StructRepr"
    TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (RegEntry sym tp -> TypeRepr tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> TypeRepr tp
C.regType RegEntry sym tp
left) (Assignment (RegValue' sym) ctx -> RegEntry sym tp)
-> (Assignment (RegEntry sym) ctx
    -> Assignment (RegValue' sym) ctx)
-> Assignment (RegEntry sym) ctx
-> RegEntry sym tp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: CrucibleType). RegEntry sym x -> RegValue' sym x)
-> forall (x :: Ctx CrucibleType).
   Assignment (RegEntry sym) x -> Assignment (RegValue' sym) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: CrucibleType -> Type) (g :: CrucibleType -> Type).
(forall (x :: CrucibleType). f x -> g x)
-> forall (x :: Ctx CrucibleType). Assignment f x -> Assignment g x
fmapFC (RegValue sym x -> RegValue' sym x
forall sym (tp :: CrucibleType).
RegValue sym tp -> RegValue' sym tp
C.RV (RegValue sym x -> RegValue' sym x)
-> (RegEntry sym x -> RegValue sym x)
-> RegEntry sym x
-> RegValue' sym x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegEntry sym x -> RegValue sym x
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue) (Assignment (RegEntry sym) ctx -> RegEntry sym tp)
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
-> FixpointMonad sym (RegEntry sym tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
forall sym (ctx :: Ctx CrucibleType).
(?logMessage::String -> IO (), IsSymInterface sym) =>
sym
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
joinRegEntries sym
sym
      (Size ctx
-> (forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
-> Assignment (RegEntry sym) ctx
forall {k} (ctx :: Ctx k) (f :: k -> Type).
Size ctx
-> (forall (tp :: k). Index ctx tp -> f tp) -> Assignment f ctx
Ctx.generate (CtxRepr ctx -> Size ctx
forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size CtxRepr ctx
field_types) ((forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
 -> Assignment (RegEntry sym) ctx)
-> (forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
-> Assignment (RegEntry sym) ctx
forall a b. (a -> b) -> a -> b
$ \Index ctx tp
i ->
        TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (CtxRepr ctx
field_types CtxRepr ctx -> Index ctx tp -> TypeRepr tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i) (RegValue sym tp -> RegEntry sym tp)
-> RegValue sym tp -> RegEntry sym tp
forall a b. (a -> b) -> a -> b
$ RegValue' sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType).
RegValue' sym tp -> RegValue sym tp
C.unRV (RegValue' sym tp -> RegValue sym tp)
-> RegValue' sym tp -> RegValue sym tp
forall a b. (a -> b) -> a -> b
$ (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
left) Assignment (RegValue' sym) ctx -> Index ctx tp -> RegValue' sym tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i)
      (Size ctx
-> (forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
-> Assignment (RegEntry sym) ctx
forall {k} (ctx :: Ctx k) (f :: k -> Type).
Size ctx
-> (forall (tp :: k). Index ctx tp -> f tp) -> Assignment f ctx
Ctx.generate (CtxRepr ctx -> Size ctx
forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size CtxRepr ctx
field_types) ((forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
 -> Assignment (RegEntry sym) ctx)
-> (forall {tp :: CrucibleType}. Index ctx tp -> RegEntry sym tp)
-> Assignment (RegEntry sym) ctx
forall a b. (a -> b) -> a -> b
$ \Index ctx tp
i ->
        TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (CtxRepr ctx
field_types CtxRepr ctx -> Index ctx tp -> TypeRepr tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i) (RegValue sym tp -> RegEntry sym tp)
-> RegValue sym tp -> RegEntry sym tp
forall a b. (a -> b) -> a -> b
$ RegValue' sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType).
RegValue' sym tp -> RegValue sym tp
C.unRV (RegValue' sym tp -> RegValue sym tp)
-> RegValue' sym tp -> RegValue sym tp
forall a b. (a -> b) -> a -> b
$ (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
right) Assignment (RegValue' sym) ctx -> Index ctx tp -> RegValue' sym tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i)
  TypeRepr tp
_ -> String -> FixpointMonad sym (RegEntry sym tp)
forall a. String -> FixpointMonad sym a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> FixpointMonad sym (RegEntry sym tp))
-> String -> FixpointMonad sym (RegEntry sym tp)
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint.joinRegEntry: unsupported type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show (RegEntry sym tp -> TypeRepr tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> TypeRepr tp
C.regType RegEntry sym tp
left)


applySubstitutionRegEntries ::
  C.IsSymInterface sym =>
  sym ->
  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->
  Ctx.Assignment (C.RegEntry sym) ctx ->
  Ctx.Assignment (C.RegEntry sym) ctx
applySubstitutionRegEntries :: forall sym (ctx :: Ctx CrucibleType).
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (SymExpr sym)
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
applySubstitutionRegEntries sym
sym MapF (SymExpr sym) (SymExpr sym)
substitution = (forall (x :: CrucibleType). RegEntry sym x -> RegEntry sym x)
-> forall (x :: Ctx CrucibleType).
   Assignment (RegEntry sym) x -> Assignment (RegEntry sym) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: CrucibleType -> Type) (g :: CrucibleType -> Type).
(forall (x :: CrucibleType). f x -> g x)
-> forall (x :: Ctx CrucibleType). Assignment f x -> Assignment g x
fmapFC (sym
-> MapF (SymExpr sym) (SymExpr sym)
-> RegEntry sym x
-> RegEntry sym x
forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (SymExpr sym)
-> RegEntry sym tp
-> RegEntry sym tp
applySubstitutionRegEntry sym
sym MapF (SymExpr sym) (SymExpr sym)
substitution)

applySubstitutionRegEntry ::
  C.IsSymInterface sym =>
  sym ->
  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->
  C.RegEntry sym tp ->
  C.RegEntry sym tp
applySubstitutionRegEntry :: forall sym (tp :: CrucibleType).
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (SymExpr sym)
-> RegEntry sym tp
-> RegEntry sym tp
applySubstitutionRegEntry sym
sym MapF (SymExpr sym) (SymExpr sym)
substitution RegEntry sym tp
entry = case RegEntry sym tp -> TypeRepr tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> TypeRepr tp
C.regType RegEntry sym tp
entry of
  C.LLVMPointerRepr{} ->
    RegEntry sym tp
entry
      { C.regValue = C.LLVMPointer
          (C.llvmPointerBlock (C.regValue entry))
          (MapF.findWithDefault
            (C.llvmPointerOffset (C.regValue entry))
            (C.llvmPointerOffset (C.regValue entry))
            substitution)
      }
  TypeRepr tp
C.BoolRepr ->
    RegEntry sym tp
entry
  C.StructRepr CtxRepr ctx
field_types ->
    RegEntry sym tp
entry
      { C.regValue = fmapFC (C.RV . C.regValue) $
          applySubstitutionRegEntries sym substitution $
          Ctx.generate (Ctx.size field_types) $
          \Index ctx tp
i -> TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
forall sym (tp :: CrucibleType).
TypeRepr tp -> RegValue sym tp -> RegEntry sym tp
C.RegEntry (CtxRepr ctx
field_types CtxRepr ctx -> Index ctx tp -> TypeRepr tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i) (RegValue sym tp -> RegEntry sym tp)
-> RegValue sym tp -> RegEntry sym tp
forall a b. (a -> b) -> a -> b
$ RegValue' sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType).
RegValue' sym tp -> RegValue sym tp
C.unRV (RegValue' sym tp -> RegValue sym tp)
-> RegValue' sym tp -> RegValue sym tp
forall a b. (a -> b) -> a -> b
$ (RegEntry sym tp -> RegValue sym tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> RegValue sym tp
C.regValue RegEntry sym tp
entry) Assignment (RegValue' sym) ctx -> Index ctx tp -> RegValue' sym tp
forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index ctx tp
i
      }
  TypeRepr tp
_ -> String -> [String] -> RegEntry sym tp
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.applySubstitutionRegEntry" [String
"unsupported type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRepr tp -> String
forall a. Show a => a -> String
show (RegEntry sym tp -> TypeRepr tp
forall sym (tp :: CrucibleType). RegEntry sym tp -> TypeRepr tp
C.regType RegEntry sym tp
entry)]


joinMem ::
  forall sym wptr .
  (C.IsSymInterface sym, C.HasPtrWidth wptr) =>
  sym ->
  C.MemImpl sym ->
  C.MemWrites sym ->
  IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
joinMem :: forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym
-> MemImpl sym
-> MemWrites sym
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
joinMem sym
sym MemImpl sym
mem_impl MemWrites sym
mem_writes = do
  Map
  Nat
  [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
ranges <- IO
  (Map
     Nat
     [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
-> (Map
      Nat
      [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
    -> IO
         (Map
            Nat
            [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]))
-> Maybe
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
-> IO
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
-> IO
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint: unsupported symbolic pointers") Map
  Nat
  [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
-> IO
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe
   (Map
      Nat
      [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
 -> IO
      (Map
         Nat
         [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]))
-> IO
     (Maybe
        (Map
           Nat
           [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]))
-> IO
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    MaybeT
  IO
  (Map
     Nat
     [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
-> IO
     (Maybe
        (Map
           Nat
           [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall sym (w :: Nat).
(IsExprBuilder sym, HasPtrWidth w) =>
sym -> Mem sym -> MaybeT IO (Map Nat [(SymBV sym w, SymBV sym w)])
C.writeRangesMem @_ @wptr sym
sym (Mem sym
 -> MaybeT
      IO
      (Map
         Nat
         [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]))
-> Mem sym
-> MaybeT
     IO
     (Map
        Nat
        [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))])
forall a b. (a -> b) -> a -> b
$ MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
C.memImplHeap MemImpl sym
mem_impl)

  Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_subst <- case MemWrites sym
mem_writes of
    C.MemWrites [C.MemWritesChunkIndexed IntMap [MemWrite sym]
indexed_writes] -> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(MemLocation sym wptr, MemFixpointEntry sym wptr)]
 -> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
-> ([Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
    -> [(MemLocation sym wptr, MemFixpointEntry sym wptr)])
-> [Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
 -> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
-> IO [Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (MemWrite sym
 -> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)))
-> [MemWrite sym]
-> IO [Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM
      (\case
        C.MemWrite LLVMPtr sym w
ptr WriteSource sym w
mem_source
          | Just wptr :~: w
Refl <- NatRepr wptr -> NatRepr w -> Maybe (wptr :~: w)
forall (a :: Nat) (b :: Nat).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
W4.testEquality ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth (LLVMPtr sym w -> NatRepr w
forall sym (w :: Nat).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
C.ptrWidth LLVMPtr sym w
ptr)
          , Just Nat
blk <- SymNat sym -> Maybe Nat
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Nat
W4.asNat (LLVMPtr sym wptr -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock LLVMPtr sym wptr
LLVMPtr sym w
ptr) -> do
            SymExpr sym (BaseBVType wptr)
sz <- IO (SymExpr sym (BaseBVType wptr))
-> (SymExpr sym (BaseBVType wptr)
    -> IO (SymExpr sym (BaseBVType wptr)))
-> Maybe (SymExpr sym (BaseBVType wptr))
-> IO (SymExpr sym (BaseBVType wptr))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (SymExpr sym (BaseBVType wptr))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint: unsupported MemSource") SymExpr sym (BaseBVType wptr) -> IO (SymExpr sym (BaseBVType wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (SymExpr sym (BaseBVType wptr))
 -> IO (SymExpr sym (BaseBVType wptr)))
-> IO (Maybe (SymExpr sym (BaseBVType wptr)))
-> IO (SymExpr sym (BaseBVType wptr))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              MaybeT IO (SymExpr sym (BaseBVType wptr))
-> IO (Maybe (SymExpr sym (BaseBVType wptr)))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (sym -> NatRepr w -> WriteSource sym w -> MaybeT IO (SymBV sym w)
forall sym (w :: Nat).
(IsExprBuilder sym, 1 <= w) =>
sym -> NatRepr w -> WriteSource sym w -> MaybeT IO (SymBV sym w)
C.writeSourceSize sym
sym (LLVMPtr sym w -> NatRepr w
forall sym (w :: Nat).
IsExprBuilder sym =>
LLVMPtr sym w -> NatRepr w
C.ptrWidth LLVMPtr sym w
ptr) WriteSource sym w
mem_source)
            let mem_loc :: MemLocation sym wptr
mem_loc = MemLocation
                  { memLocationBlock :: Nat
memLocationBlock = Nat
blk
                  , memLocationOffset :: SymExpr sym (BaseBVType wptr)
memLocationOffset = LLVMPtr sym wptr -> SymExpr sym (BaseBVType wptr)
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset LLVMPtr sym wptr
LLVMPtr sym w
ptr
                  , memLocationSize :: SymExpr sym (BaseBVType wptr)
memLocationSize = SymExpr sym (BaseBVType wptr)
sz
                  }

            Bool
is_loop_local <- [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))
 -> IO Bool)
-> [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
-> IO [Bool]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM
              (\(SymExpr sym (BaseBVType wptr)
prev_off, SymExpr sym (BaseBVType wptr)
prev_sz) -> do
                SymExpr sym BaseBoolType
disjoint_pred <- sym
-> LLVMPtr sym wptr
-> SymExpr sym (BaseBVType wptr)
-> LLVMPtr sym wptr
-> SymExpr sym (BaseBVType wptr)
-> IO (SymExpr sym BaseBoolType)
forall (wptr :: Nat) sym.
(HasPtrWidth wptr, IsSymInterface sym) =>
sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (Pred sym)
C.buildDisjointRegionsAssertionWithSub
                  sym
sym
                  LLVMPtr sym wptr
LLVMPtr sym w
ptr
                  SymExpr sym (BaseBVType wptr)
sz
                  (SymNat sym -> SymExpr sym (BaseBVType wptr) -> LLVMPointer sym wptr
forall sym (w :: Nat).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
C.LLVMPointer (LLVMPtr sym wptr -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock LLVMPtr sym wptr
LLVMPtr sym w
ptr) SymExpr sym (BaseBVType wptr)
prev_off)
                  SymExpr sym (BaseBVType wptr)
prev_sz
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
W4.asConstantPred SymExpr sym BaseBoolType
disjoint_pred Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
              ([(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
-> Nat
-> Map
     Nat
     [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
-> [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Nat
blk Map
  Nat
  [(SymExpr sym (BaseBVType wptr), SymExpr sym (BaseBVType wptr))]
ranges)

            if Bool -> Bool
not Bool
is_loop_local then do
              MemFixpointEntry sym wptr
mem_entry <- case WriteSource sym w
mem_source of
                C.MemStore LLVMVal sym
_ StorageType
storage_type Alignment
_ ->
                  case Nat -> Some NatRepr
W4.mkNatRepr (Nat -> Some NatRepr) -> Nat -> Some NatRepr
forall a b. (a -> b) -> a -> b
$ Addr -> Nat
C.bytesToBits (Addr -> StorageType -> Addr
C.typeEnd Addr
0 StorageType
storage_type) of
                    C.Some NatRepr x
bv_width
                      | Just LeqProof 1 x
C.LeqProof <- NatRepr 1 -> NatRepr x -> Maybe (LeqProof 1 x)
forall (m :: Nat) (n :: Nat).
NatRepr m -> NatRepr n -> Maybe (LeqProof m n)
W4.testLeq (forall (n :: Nat). KnownNat n => NatRepr n
W4.knownNat @1) NatRepr x
bv_width -> do
                        SymExpr sym ('BaseBVType x)
join_variable <- sym
-> SolverSymbol
-> BaseTypeRepr ('BaseBVType x)
-> IO (SymExpr sym ('BaseBVType x))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
W4.freshConstant sym
sym (String -> SolverSymbol
W4.safeSymbol String
"mem_join_var") (NatRepr x -> BaseTypeRepr ('BaseBVType x)
forall (w :: Nat).
(1 <= w) =>
NatRepr w -> BaseTypeRepr ('BaseBVType w)
W4.BaseBVRepr NatRepr x
bv_width)
                        MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr))
-> MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr)
forall a b. (a -> b) -> a -> b
$ SymExpr sym ('BaseBVType x)
-> StorageType -> MemFixpointEntry sym wptr
forall (b :: Nat) sym (wptr :: Nat).
(1 <= b) =>
SymBV sym b -> StorageType -> MemFixpointEntry sym wptr
MemStoreFixpointEntry SymExpr sym ('BaseBVType x)
join_variable StorageType
storage_type
                      | Bool
otherwise ->
                        String -> [String] -> IO (MemFixpointEntry sym wptr)
forall a. HasCallStack => String -> [String] -> a
C.panic
                          String
"SimpleLoopFixpoint.simpleLoopFixpoint"
                          [String
"unexpected storage type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageType -> String
forall a. Show a => a -> String
show StorageType
storage_type]

                C.MemArrayStore SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr Maybe (SymBV sym w)
_ -> do
                  SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
join_variable <- sym
-> SolverSymbol
-> BaseTypeRepr
     (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> IO
     (SymExpr
        sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8)))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
W4.freshConstant sym
sym (String -> SolverSymbol
W4.safeSymbol String
"mem_join_var") (SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> BaseTypeRepr
     (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
forall (tp :: BaseType). SymExpr sym tp -> BaseTypeRepr tp
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
arr)
                  MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr))
-> MemFixpointEntry sym wptr -> IO (MemFixpointEntry sym wptr)
forall a b. (a -> b) -> a -> b
$ SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
-> SymExpr sym (BaseBVType wptr) -> MemFixpointEntry sym wptr
forall sym (wptr :: Nat).
SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> SymBV sym wptr -> MemFixpointEntry sym wptr
MemArrayFixpointEntry SymExpr
  sym (BaseArrayType (SingleCtx (BaseBVType wptr)) (BaseBVType 8))
join_variable SymExpr sym (BaseBVType wptr)
sz

                WriteSource sym w
_ -> String -> IO (MemFixpointEntry sym wptr)
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint.joinMem: unsupported MemSource"

              Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
-> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
 -> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)))
-> Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
-> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr))
forall a b. (a -> b) -> a -> b
$ (MemLocation sym wptr, MemFixpointEntry sym wptr)
-> Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
forall a. a -> Maybe a
Just (MemLocation sym wptr
mem_loc, MemFixpointEntry sym wptr
mem_entry)

            else
              Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
-> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)
forall a. Maybe a
Nothing

        MemWrite sym
_ -> String
-> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr)))
-> String
-> IO (Maybe (MemLocation sym wptr, MemFixpointEntry sym wptr))
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: not MemWrite: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (MemWrites sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => MemWrites sym -> Doc ann
C.ppMemWrites MemWrites sym
mem_writes))
      ([[MemWrite sym]] -> [MemWrite sym]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
List.concat ([[MemWrite sym]] -> [MemWrite sym])
-> [[MemWrite sym]] -> [MemWrite sym]
forall a b. (a -> b) -> a -> b
$ IntMap [MemWrite sym] -> [[MemWrite sym]]
forall a. IntMap a -> [a]
IntMap.elems IntMap [MemWrite sym]
indexed_writes)

    C.MemWrites [] -> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall k a. Map k a
Map.empty

    MemWrites sym
_ -> String
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)))
-> String
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: not MemWritesChunkIndexed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (MemWrites sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => MemWrites sym -> Doc ann
C.ppMemWrites MemWrites sym
mem_writes)

  sym -> [MemLocation sym wptr] -> IO ()
forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> [MemLocation sym wptr] -> IO ()
checkDisjointRegions sym
sym ([MemLocation sym wptr] -> IO ())
-> [MemLocation sym wptr] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [MemLocation sym wptr]
forall k a. Map k a -> [k]
Map.keys Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_subst

  Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_subst

checkDisjointRegions ::
  (C.IsSymInterface sym, C.HasPtrWidth wptr) =>
  sym ->
  [MemLocation sym wptr] ->
  IO ()
checkDisjointRegions :: forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> [MemLocation sym wptr] -> IO ()
checkDisjointRegions sym
sym = \case
  MemLocation sym wptr
hd_mem_loc : [MemLocation sym wptr]
tail_mem_locs -> do
    (MemLocation sym wptr -> IO ()) -> [MemLocation sym wptr] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (sym -> MemLocation sym wptr -> MemLocation sym wptr -> IO ()
forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> MemLocation sym wptr -> MemLocation sym wptr -> IO ()
checkDisjointRegions' sym
sym MemLocation sym wptr
hd_mem_loc) [MemLocation sym wptr]
tail_mem_locs
    sym -> [MemLocation sym wptr] -> IO ()
forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> [MemLocation sym wptr] -> IO ()
checkDisjointRegions sym
sym [MemLocation sym wptr]
tail_mem_locs
  [] -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

checkDisjointRegions' ::
  (C.IsSymInterface sym, C.HasPtrWidth wptr) =>
  sym ->
  MemLocation sym wptr ->
  MemLocation sym wptr ->
  IO ()
checkDisjointRegions' :: forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym -> MemLocation sym wptr -> MemLocation sym wptr -> IO ()
checkDisjointRegions' sym
sym MemLocation sym wptr
mem_loc1 MemLocation sym wptr
mem_loc2 = do
  LLVMPointer sym wptr
ptr1 <- sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
forall sym (wptr :: Nat).
IsSymInterface sym =>
sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
memLocationPtr sym
sym MemLocation sym wptr
mem_loc1
  LLVMPointer sym wptr
ptr2 <- sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
forall sym (wptr :: Nat).
IsSymInterface sym =>
sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
memLocationPtr sym
sym MemLocation sym wptr
mem_loc2
  SymExpr sym BaseBoolType
disjoint_pred <- sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (SymExpr sym BaseBoolType)
forall (wptr :: Nat) sym.
(HasPtrWidth wptr, IsSymInterface sym) =>
sym
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> LLVMPtr sym wptr
-> SymBV sym wptr
-> IO (Pred sym)
C.buildDisjointRegionsAssertionWithSub
    sym
sym
    LLVMPtr sym wptr
LLVMPointer sym wptr
ptr1
    (MemLocation sym wptr -> SymBV sym wptr
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym wptr
mem_loc1)
    LLVMPtr sym wptr
LLVMPointer sym wptr
ptr2
    (MemLocation sym wptr -> SymBV sym wptr
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym wptr
mem_loc2)
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
W4.asConstantPred SymExpr sym BaseBoolType
disjoint_pred Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"SimpleLoopFixpoint: non-disjoint ranges: off1="
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymBV sym wptr -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymBV sym wptr -> Doc Any) -> SymBV sym wptr -> Doc Any
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym wptr -> SymBV sym wptr
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset LLVMPtr sym wptr
LLVMPointer sym wptr
ptr1)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", sz1="
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymBV sym wptr -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymBV sym wptr -> Doc Any) -> SymBV sym wptr -> Doc Any
forall a b. (a -> b) -> a -> b
$ MemLocation sym wptr -> SymBV sym wptr
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym wptr
mem_loc1)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", off2="
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymBV sym wptr -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymBV sym wptr -> Doc Any) -> SymBV sym wptr -> Doc Any
forall a b. (a -> b) -> a -> b
$ LLVMPtr sym wptr -> SymBV sym wptr
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset LLVMPtr sym wptr
LLVMPointer sym wptr
ptr2)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", sz2="
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (SymBV sym wptr -> Doc Any
forall (tp :: BaseType) ann. SymExpr sym tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymBV sym wptr -> Doc Any) -> SymBV sym wptr -> Doc Any
forall a b. (a -> b) -> a -> b
$ MemLocation sym wptr -> SymBV sym wptr
forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationSize MemLocation sym wptr
mem_loc2)


loadMemJoinVariables ::
  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>
  bak ->
  C.MemImpl sym ->
  Map (MemLocation sym wptr) (MemFixpointEntry sym wptr) ->
  IO (MapF (W4.SymExpr sym) (W4.SymExpr sym))
loadMemJoinVariables :: forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
loadMemJoinVariables bak
bak MemImpl sym
mem Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
subst =
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
C.backendGetSym bak
bak in
  [Pair (SymExpr sym) (SymExpr sym)]
-> MapF (SymExpr sym) (SymExpr sym)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
[Pair k a] -> MapF k a
MapF.fromList ([Pair (SymExpr sym) (SymExpr sym)]
 -> MapF (SymExpr sym) (SymExpr sym))
-> ([Maybe (Pair (SymExpr sym) (SymExpr sym))]
    -> [Pair (SymExpr sym) (SymExpr sym)])
-> [Maybe (Pair (SymExpr sym) (SymExpr sym))]
-> MapF (SymExpr sym) (SymExpr sym)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Pair (SymExpr sym) (SymExpr sym))]
-> [Pair (SymExpr sym) (SymExpr sym)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Pair (SymExpr sym) (SymExpr sym))]
 -> MapF (SymExpr sym) (SymExpr sym))
-> IO [Maybe (Pair (SymExpr sym) (SymExpr sym))]
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((MemLocation sym wptr, MemFixpointEntry sym wptr)
 -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym))))
-> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> IO [Maybe (Pair (SymExpr sym) (SymExpr sym))]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM
    (\(MemLocation sym wptr
mem_loc, MemFixpointEntry sym wptr
mem_entry) -> do
      LLVMPointer sym wptr
ptr <- sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
forall sym (wptr :: Nat).
IsSymInterface sym =>
sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
memLocationPtr sym
sym MemLocation sym wptr
mem_loc
      case MemFixpointEntry sym wptr
mem_entry of
        MemStoreFixpointEntry SymBV sym w
join_variable StorageType
storage_type -> do
          RegValue sym (LLVMPointerType w)
val <- bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr (LLVMPointerType w)
-> Alignment
-> IO (RegValue sym (LLVMPointerType w))
forall sym bak (wptr :: Nat) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> StorageType
-> TypeRepr tp
-> Alignment
-> IO (RegValue sym tp)
C.doLoad bak
bak MemImpl sym
mem LLVMPtr sym wptr
LLVMPointer sym wptr
ptr StorageType
storage_type (NatRepr w -> TypeRepr (LLVMPointerType w)
forall (ty :: CrucibleType) (w :: Nat).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
C.LLVMPointerRepr (NatRepr w -> TypeRepr (LLVMPointerType w))
-> NatRepr w -> TypeRepr (LLVMPointerType w)
forall a b. (a -> b) -> a -> b
$ SymBV sym w -> NatRepr w
forall (w :: Nat). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
W4.bvWidth SymBV sym w
join_variable) Alignment
C.noAlignment
          case SymNat sym -> Maybe Nat
forall sym. IsExpr (SymExpr sym) => SymNat sym -> Maybe Nat
W4.asNat (RegValue sym (LLVMPointerType w) -> SymNat sym
forall sym (w :: Nat). LLVMPtr sym w -> SymNat sym
C.llvmPointerBlock RegValue sym (LLVMPointerType w)
val) of
                Just Nat
0 -> Maybe (Pair (SymExpr sym) (SymExpr sym))
-> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Pair (SymExpr sym) (SymExpr sym))
 -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym))))
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
-> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a b. (a -> b) -> a -> b
$ Pair (SymExpr sym) (SymExpr sym)
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
forall a. a -> Maybe a
Just (Pair (SymExpr sym) (SymExpr sym)
 -> Maybe (Pair (SymExpr sym) (SymExpr sym)))
-> Pair (SymExpr sym) (SymExpr sym)
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
forall a b. (a -> b) -> a -> b
$  SymBV sym w -> SymBV sym w -> Pair (SymExpr sym) (SymExpr sym)
forall {k} (a :: k -> Type) (tp :: k) (b :: k -> Type).
a tp -> b tp -> Pair a b
MapF.Pair SymBV sym w
join_variable (SymBV sym w -> Pair (SymExpr sym) (SymExpr sym))
-> SymBV sym w -> Pair (SymExpr sym) (SymExpr sym)
forall a b. (a -> b) -> a -> b
$ RegValue sym (LLVMPointerType w) -> SymBV sym w
forall sym (w :: Nat). LLVMPtr sym w -> SymBV sym w
C.llvmPointerOffset RegValue sym (LLVMPointerType w)
val
                Maybe Nat
_ -> String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym))))
-> String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (RegValue sym (LLVMPointerType w) -> Doc Any
forall sym (wptr :: Nat) ann.
IsExpr (SymExpr sym) =>
LLVMPtr sym wptr -> Doc ann
C.ppPtr RegValue sym (LLVMPointerType w)
val)
          -- foo <- C.loadRaw sym mem ptr storage_type C.noAlignment
          -- case foo of
          --   C.NoErr _p val' -> do
          --     val <- C.unpackMemValue sym (C.LLVMPointerRepr $ W4.bvWidth join_variable) val'
          --     case W4.asNat (C.llvmPointerBlock val) of
          --       Just 0 -> return $ Just $  MapF.Pair join_variable $ C.llvmPointerOffset val
          --       _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" ++ show (C.ppPtr val)
          --   C.Err{} -> -- return Nothing
          --     fail $ "SimpleLoopFixpoint.loadMemJoinVariables: loadRaw failed"
        MemArrayFixpointEntry SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
join_variable SymBV sym wptr
_size -> do
          -- TODO: handle arrays
          Maybe
  (SymExpr sym BaseBoolType,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8),
   SymBV sym wptr)
maybe_allocation_array <- sym
-> NatRepr wptr
-> LLVMPtr sym wptr
-> Mem sym
-> IO
     (Maybe
        (SymExpr sym BaseBoolType,
         SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8),
         SymBV sym wptr))
forall sym (w :: Nat).
(IsSymInterface sym, 1 <= w) =>
sym
-> NatRepr w
-> LLVMPtr sym w
-> Mem sym
-> IO
     (Maybe
        (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8),
         SymBV sym w))
C.asMemAllocationArrayStore sym
sym ?ptrWidth::NatRepr wptr
NatRepr wptr
?ptrWidth LLVMPtr sym wptr
LLVMPointer sym wptr
ptr (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
C.memImplHeap MemImpl sym
mem)
          case Maybe
  (SymExpr sym BaseBoolType,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8),
   SymBV sym wptr)
maybe_allocation_array of
            Just (SymExpr sym BaseBoolType
ok, SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
arr, SymBV sym wptr
_arr_sz) | Just Bool
True <- SymExpr sym BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
W4.asConstantPred SymExpr sym BaseBoolType
ok -> do
              Maybe (Pair (SymExpr sym) (SymExpr sym))
-> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (Pair (SymExpr sym) (SymExpr sym))
 -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym))))
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
-> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a b. (a -> b) -> a -> b
$ Pair (SymExpr sym) (SymExpr sym)
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
forall a. a -> Maybe a
Just (Pair (SymExpr sym) (SymExpr sym)
 -> Maybe (Pair (SymExpr sym) (SymExpr sym)))
-> Pair (SymExpr sym) (SymExpr sym)
-> Maybe (Pair (SymExpr sym) (SymExpr sym))
forall a b. (a -> b) -> a -> b
$ SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> Pair (SymExpr sym) (SymExpr sym)
forall {k} (a :: k -> Type) (tp :: k) (b :: k -> Type).
a tp -> b tp -> Pair a b
MapF.Pair SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
join_variable SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
arr
            Maybe
  (SymExpr sym BaseBoolType,
   SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8),
   SymBV sym wptr)
_ -> String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym))))
-> String -> IO (Maybe (Pair (SymExpr sym) (SymExpr sym)))
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint.loadMemJoinVariables")
    (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
subst)

storeMemJoinVariables ::
  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>
  bak ->
  C.MemImpl sym ->
  Map (MemLocation sym wptr) (MemFixpointEntry sym wptr) ->
  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->
  IO (C.MemImpl sym)
storeMemJoinVariables :: forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
storeMemJoinVariables bak
bak MemImpl sym
mem Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_subst MapF (SymExpr sym) (SymExpr sym)
eq_subst = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
C.backendGetSym bak
bak
  (MemImpl sym
 -> (MemLocation sym wptr, MemFixpointEntry sym wptr)
 -> IO (MemImpl sym))
-> MemImpl sym
-> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
-> IO (MemImpl sym)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
    (\MemImpl sym
mem_acc (MemLocation sym wptr
mem_loc, MemFixpointEntry sym wptr
mem_entry) -> do
      LLVMPointer sym wptr
ptr <- sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
forall sym (wptr :: Nat).
IsSymInterface sym =>
sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
memLocationPtr sym
sym MemLocation sym wptr
mem_loc
      case MemFixpointEntry sym wptr
mem_entry of
        MemStoreFixpointEntry SymBV sym w
join_variable StorageType
storage_type -> do
          bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> TypeRepr (LLVMPointerType w)
-> StorageType
-> Alignment
-> RegValue sym (LLVMPointerType w)
-> IO (MemImpl sym)
forall sym bak (wptr :: Nat) (tp :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> TypeRepr tp
-> StorageType
-> Alignment
-> RegValue sym tp
-> IO (MemImpl sym)
C.doStore bak
bak MemImpl sym
mem_acc LLVMPtr sym wptr
LLVMPointer sym wptr
ptr (NatRepr w -> TypeRepr (LLVMPointerType w)
forall (ty :: CrucibleType) (w :: Nat).
(1 <= w, ty ~ LLVMPointerType w) =>
NatRepr w -> TypeRepr ty
C.LLVMPointerRepr (NatRepr w -> TypeRepr (LLVMPointerType w))
-> NatRepr w -> TypeRepr (LLVMPointerType w)
forall a b. (a -> b) -> a -> b
$ SymBV sym w -> NatRepr w
forall (w :: Nat). SymExpr sym (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
W4.bvWidth SymBV sym w
join_variable) StorageType
storage_type Alignment
C.noAlignment (RegValue sym (LLVMPointerType w) -> IO (MemImpl sym))
-> IO (RegValue sym (LLVMPointerType w)) -> IO (MemImpl sym)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            sym -> SymBV sym w -> IO (RegValue sym (LLVMPointerType w))
forall sym (w :: Nat).
IsSymInterface sym =>
sym -> SymBV sym w -> IO (LLVMPtr sym w)
C.llvmPointer_bv sym
sym (MapF (SymExpr sym) (SymExpr sym) -> SymBV sym w -> SymBV sym w
forall a (k :: a -> Type) (tp :: a).
OrdF k =>
MapF k k -> k tp -> k tp
findWithDefaultKey MapF (SymExpr sym) (SymExpr sym)
eq_subst SymBV sym w
join_variable)
        MemArrayFixpointEntry SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
join_variable SymBV sym wptr
size -> do
          bak
-> MemImpl sym
-> LLVMPtr sym wptr
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> SymBV sym wptr
-> IO (MemImpl sym)
forall sym bak (w :: Nat).
(IsSymBackend sym bak, HasPtrWidth w, HasLLVMAnn sym) =>
bak
-> MemImpl sym
-> LLVMPtr sym w
-> Alignment
-> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)
-> SymBV sym w
-> IO (MemImpl sym)
C.doArrayStore bak
bak MemImpl sym
mem_acc LLVMPtr sym wptr
LLVMPointer sym wptr
ptr Alignment
C.noAlignment (MapF (SymExpr sym) (SymExpr sym)
-> SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
-> SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
forall a (k :: a -> Type) (tp :: a).
OrdF k =>
MapF k k -> k tp -> k tp
findWithDefaultKey MapF (SymExpr sym) (SymExpr sym)
eq_subst SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8)
join_variable) SymBV sym wptr
size)
          -- (heap, p1, p2) <- C.writeArrayMem
          --   sym
          --   ?ptrWidth
          --   ptr
          --   C.noAlignment
          --   (findWithDefaultKey eq_subst join_variable)
          --   (Just size)
          --   (C.memImplHeap mem_acc)
          -- return $ mem_acc { C.memImplHeap = heap })
    MemImpl sym
mem
    (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [(MemLocation sym wptr, MemFixpointEntry sym wptr)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_subst)

memLocationPtr ::
  C.IsSymInterface sym =>
  sym ->
  MemLocation sym wptr ->
  IO (C.LLVMPtr sym wptr)
memLocationPtr :: forall sym (wptr :: Nat).
IsSymInterface sym =>
sym -> MemLocation sym wptr -> IO (LLVMPtr sym wptr)
memLocationPtr sym
sym (MemLocation { memLocationBlock :: forall sym (w :: Nat). MemLocation sym w -> Nat
memLocationBlock = Nat
blk, memLocationOffset :: forall sym (w :: Nat). MemLocation sym w -> SymBV sym w
memLocationOffset = SymBV sym wptr
off }) =
  SymNat sym -> SymBV sym wptr -> LLVMPointer sym wptr
forall sym (w :: Nat).
SymNat sym -> SymBV sym w -> LLVMPointer sym w
C.LLVMPointer (SymNat sym -> SymBV sym wptr -> LLVMPointer sym wptr)
-> IO (SymNat sym) -> IO (SymBV sym wptr -> LLVMPointer sym wptr)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> Nat -> IO (SymNat sym)
forall sym. IsExprBuilder sym => sym -> Nat -> IO (SymNat sym)
W4.natLit sym
sym Nat
blk IO (SymBV sym wptr -> LLVMPointer sym wptr)
-> IO (SymBV sym wptr) -> IO (LLVMPointer sym wptr)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SymBV sym wptr -> IO (SymBV sym wptr)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymBV sym wptr
off


dropMemStackFrame :: C.IsSymInterface sym => C.MemImpl sym -> (C.MemImpl sym, C.MemAllocs sym, C.MemWrites sym)
dropMemStackFrame :: forall sym.
IsSymInterface sym =>
MemImpl sym -> (MemImpl sym, MemAllocs sym, MemWrites sym)
dropMemStackFrame MemImpl sym
mem = case (MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
C.memImplHeap MemImpl sym
mem) Mem sym
-> Getting (MemState sym) (Mem sym) (MemState sym) -> MemState sym
forall s a. s -> Getting a s a -> a
^. Getting (MemState sym) (Mem sym) (MemState sym)
forall sym (f :: Type -> Type).
Functor f =>
(MemState sym -> f (MemState sym)) -> Mem sym -> f (Mem sym)
C.memState of
  (C.StackFrame Int
_ Int
_ Text
_ (MemAllocs sym
a, MemWrites sym
w) MemState sym
s) -> ((MemImpl sym
mem { C.memImplHeap = (C.memImplHeap mem) & C.memState .~ s }), MemAllocs sym
a, MemWrites sym
w)
  MemState sym
_ -> String -> [String] -> (MemImpl sym, MemAllocs sym, MemWrites sym)
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.dropMemStackFrame" [String
"not a stack frame:", Doc Any -> String
forall a. Show a => a -> String
show (Mem sym -> Doc Any
forall sym ann. IsExpr (SymExpr sym) => Mem sym -> Doc ann
C.ppMem (Mem sym -> Doc Any) -> Mem sym -> Doc Any
forall a b. (a -> b) -> a -> b
$ MemImpl sym -> Mem sym
forall sym. MemImpl sym -> Mem sym
C.memImplHeap MemImpl sym
mem)]


filterSubstitution ::
  C.IsSymInterface sym =>
  sym ->
  MapF (W4.SymExpr sym) (FixpointEntry sym) ->
  MapF (W4.SymExpr sym) (FixpointEntry sym)
filterSubstitution :: forall sym.
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
filterSubstitution sym
sym MapF (SymExpr sym) (FixpointEntry sym)
substitution =
  -- TODO: fixpoint
  let uninterp_constants :: Set (Some (SymExpr sym))
uninterp_constants = (forall (s :: BaseType).
 FixpointEntry sym s -> Set (Some (SymExpr sym)))
-> MapF (SymExpr sym) (FixpointEntry sym)
-> Set (Some (SymExpr sym))
forall m (e :: BaseType -> Type).
Monoid m =>
(forall (s :: BaseType). e s -> m) -> MapF (SymExpr sym) e -> m
forall k (t :: (k -> Type) -> Type) m (e :: k -> Type).
(FoldableF t, Monoid m) =>
(forall (s :: k). e s -> m) -> t e -> m
foldMapF
        ((Some (BoundVar sym) -> Some (SymExpr sym))
-> Set (Some (BoundVar sym)) -> Set (Some (SymExpr sym))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). BoundVar sym tp -> SymExpr sym tp)
-> Some (BoundVar sym) -> Some (SymExpr sym)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
C.mapSome ((forall (tp :: BaseType). BoundVar sym tp -> SymExpr sym tp)
 -> Some (BoundVar sym) -> Some (SymExpr sym))
-> (forall (tp :: BaseType). BoundVar sym tp -> SymExpr sym tp)
-> Some (BoundVar sym)
-> Some (SymExpr sym)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (BoundVar sym)) -> Set (Some (SymExpr sym)))
-> (FixpointEntry sym s -> Set (Some (BoundVar sym)))
-> FixpointEntry sym s
-> Set (Some (SymExpr sym))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym -> SymExpr sym s -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (SymExpr sym s -> Set (Some (BoundVar sym)))
-> (FixpointEntry sym s -> SymExpr sym s)
-> FixpointEntry sym s
-> Set (Some (BoundVar sym))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixpointEntry sym s -> SymExpr sym s
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue)
        MapF (SymExpr sym) (FixpointEntry sym)
substitution
  in
  (forall (tp :: BaseType).
 SymExpr sym tp -> FixpointEntry sym tp -> Bool)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall {v} (k :: v -> Type) (f :: v -> Type).
(forall (tp :: v). k tp -> f tp -> Bool) -> MapF k f -> MapF k f
MapF.filterWithKey (\SymExpr sym tp
variable FixpointEntry sym tp
_entry -> Some (SymExpr sym) -> Set (Some (SymExpr sym)) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (SymExpr sym tp -> Some (SymExpr sym)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some SymExpr sym tp
variable) Set (Some (SymExpr sym))
uninterp_constants) MapF (SymExpr sym) (FixpointEntry sym)
substitution

loopIndexLinearSubstitution ::
  (C.IsSymInterface sym, C.HasPtrWidth wptr, MonadIO m) =>
  sym ->
  W4.SymBV sym wptr ->
  MapF (W4.SymExpr sym) (FixpointEntry sym) ->
  m (MapF (W4.SymExpr sym) (W4.SymExpr sym))
loopIndexLinearSubstitution :: forall sym (wptr :: Nat) (m :: Type -> Type).
(IsSymInterface sym, HasPtrWidth wptr, MonadIO m) =>
sym
-> SymBV sym wptr
-> MapF (SymExpr sym) (FixpointEntry sym)
-> m (MapF (SymExpr sym) (SymExpr sym))
loopIndexLinearSubstitution sym
sym SymBV sym wptr
index_variable =
  (forall (tp :: BaseType).
 SymExpr sym tp
 -> FixpointEntry sym tp -> m (Maybe (SymExpr sym tp)))
-> MapF (SymExpr sym) (FixpointEntry sym)
-> m (MapF (SymExpr sym) (SymExpr sym))
forall {v} (f :: Type -> Type) (k :: v -> Type) (a :: v -> Type)
       (b :: v -> Type).
Applicative f =>
(forall (tp :: v). k tp -> a tp -> f (Maybe (b tp)))
-> MapF k a -> f (MapF k b)
MapF.traverseMaybeWithKey
    (\SymExpr sym tp
variable FixpointEntry sym tp
entry -> case BaseTypeRepr tp
-> BaseTypeRepr (BaseBVType wptr) -> Maybe (tp :~: BaseBVType wptr)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
BaseTypeRepr a -> BaseTypeRepr b -> Maybe (a :~: b)
W4.testEquality (SymExpr sym tp -> BaseTypeRepr tp
forall (tp :: BaseType). SymExpr sym tp -> BaseTypeRepr tp
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType SymExpr sym tp
variable) (SymBV sym wptr -> BaseTypeRepr (BaseBVType wptr)
forall (tp :: BaseType). SymExpr sym tp -> BaseTypeRepr tp
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType SymBV sym wptr
index_variable) of
      Just tp :~: BaseBVType wptr
Refl -> do
        SymBV sym wptr
diff <- IO (SymBV sym wptr) -> m (SymBV sym wptr)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SymBV sym wptr) -> m (SymBV sym wptr))
-> IO (SymBV sym wptr) -> m (SymBV sym wptr)
forall a b. (a -> b) -> a -> b
$ sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Nat).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Nat).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
W4.bvSub sym
sym (FixpointEntry sym tp -> SymExpr sym tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
entry) SymExpr sym tp
SymBV sym wptr
variable
        case SymBV sym wptr -> Maybe (BV wptr)
forall (w :: Nat). SymExpr sym (BaseBVType w) -> Maybe (BV w)
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> Maybe (BV w)
W4.asBV SymBV sym wptr
diff of
          Just{} -> IO (Maybe (SymExpr sym tp)) -> m (Maybe (SymExpr sym tp))
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SymExpr sym tp)) -> m (Maybe (SymExpr sym tp)))
-> IO (Maybe (SymExpr sym tp)) -> m (Maybe (SymExpr sym tp))
forall a b. (a -> b) -> a -> b
$ SymExpr sym tp -> Maybe (SymExpr sym tp)
forall a. a -> Maybe a
Just (SymExpr sym tp -> Maybe (SymExpr sym tp))
-> IO (SymExpr sym tp) -> IO (Maybe (SymExpr sym tp))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Nat).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Nat).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
W4.bvAdd sym
sym (FixpointEntry sym tp -> SymExpr sym tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue FixpointEntry sym tp
entry) (SymBV sym wptr -> IO (SymExpr sym tp))
-> IO (SymBV sym wptr) -> IO (SymExpr sym tp)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Nat).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Nat).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
W4.bvMul sym
sym SymBV sym wptr
index_variable SymBV sym wptr
diff)
          Maybe (BV wptr)
Nothing -> Maybe (SymExpr sym tp) -> m (Maybe (SymExpr sym tp))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SymExpr sym tp)
forall a. Maybe a
Nothing
      Maybe (tp :~: BaseBVType wptr)
Nothing -> Maybe (SymExpr sym tp) -> m (Maybe (SymExpr sym tp))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SymExpr sym tp)
forall a. Maybe a
Nothing)

-- find widening variables that are actually the same (up to syntactic equality)
-- and can be substituted for each other
uninterpretedConstantEqualitySubstitution ::
  (C.IsSymInterface sym, sym ~ W4.ExprBuilder t st fs, MonadIO m, MonadFail m, ?logMessage :: String -> IO ()) =>
  sym ->
  MapF (W4.SymExpr sym) (FixpointEntry sym) ->
  m (MapF (W4.SymExpr sym) (FixpointEntry sym), MapF (W4.SymExpr sym) (W4.SymExpr sym))
uninterpretedConstantEqualitySubstitution :: forall sym t (st :: Type -> Type) fs (m :: Type -> Type).
(IsSymInterface sym, sym ~ ExprBuilder t st fs, MonadIO m,
 MonadFail m, ?logMessage::String -> IO ()) =>
sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> m (MapF (SymExpr sym) (FixpointEntry sym),
      MapF (SymExpr sym) (SymExpr sym))
uninterpretedConstantEqualitySubstitution sym
sym MapF (SymExpr sym) (FixpointEntry sym)
substitution = do
  let reverse_substitution :: MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
reverse_substitution = (forall (s :: BaseType).
 MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
 -> Expr t s
 -> FixpointEntry sym s
 -> MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t))
-> MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
forall {v} b (k :: v -> Type) (a :: v -> Type).
(forall (s :: v). b -> k s -> a s -> b) -> b -> MapF k a -> b
MapF.foldlWithKey'
        (\MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
accumulator Expr t s
variable FixpointEntry sym s
entry -> FixpointEntry sym s
-> Expr t s
-> MapF (FixpointEntry sym) (Expr t)
-> MapF (FixpointEntry sym) (Expr t)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert FixpointEntry sym s
entry Expr t s
variable MapF (FixpointEntry sym) (Expr t)
MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
accumulator)
        MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
        MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
substitution
  let uninterpreted_constant_substitution :: MapF (Expr t) (Expr t)
uninterpreted_constant_substitution =
        (forall (tp :: BaseType). Expr t tp -> Expr t tp -> Bool)
-> MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall {v} (k :: v -> Type) (f :: v -> Type).
(forall (tp :: v). k tp -> f tp -> Bool) -> MapF k f -> MapF k f
MapF.filterWithKey (\Expr t tp
variable Expr t tp
entry -> Maybe (tp :~: tp) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (tp :~: tp) -> Bool) -> Maybe (tp :~: tp) -> Bool
forall a b. (a -> b) -> a -> b
$ Expr t tp -> Expr t tp -> Maybe (tp :~: tp)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
Expr t a -> Expr t b -> Maybe (a :~: b)
W4.testEquality Expr t tp
variable Expr t tp
entry) (MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t))
-> MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall a b. (a -> b) -> a -> b
$
        (forall (x :: BaseType). FixpointEntry sym x -> Expr t x)
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (Expr t) f -> MapF (Expr t) g
fmapF (\FixpointEntry sym x
entry -> Maybe (Expr t x) -> Expr t x
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Expr t x) -> Expr t x) -> Maybe (Expr t x) -> Expr t x
forall a b. (a -> b) -> a -> b
$ FixpointEntry sym x
-> MapF (FixpointEntry sym) (Expr t) -> Maybe (Expr t x)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup FixpointEntry sym x
entry MapF (FixpointEntry sym) (Expr t)
MapF (FixpointEntry (ExprBuilder t st fs)) (Expr t)
reverse_substitution)
        MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
substitution
  let normal_substitution :: MapF (Expr t) (FixpointEntry sym)
normal_substitution = (forall (tp :: BaseType).
 Expr t tp -> FixpointEntry sym tp -> Bool)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (f :: v -> Type).
(forall (tp :: v). k tp -> f tp -> Bool) -> MapF k f -> MapF k f
MapF.filterWithKey
        (\Expr t tp
variable FixpointEntry sym tp
_entry -> Maybe (Expr t tp) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Expr t tp) -> Bool) -> Maybe (Expr t tp) -> Bool
forall a b. (a -> b) -> a -> b
$ Expr t tp -> MapF (Expr t) (Expr t) -> Maybe (Expr t tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup Expr t tp
variable MapF (Expr t) (Expr t)
uninterpreted_constant_substitution)
        MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
substitution

  IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"vars:"
  (Pair (Expr t) (FixpointEntry sym) -> m ())
-> [Pair (Expr t) (FixpointEntry sym)] -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(MapF.Pair Expr t tp
variable FixpointEntry sym tp
entry) -> do
      let body_vars :: Set (Some (Expr t))
body_vars = (Some (ExprBoundVar t) -> Some (Expr t))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
C.mapSome ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
 -> Some (ExprBoundVar t) -> Some (Expr t))
-> (forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t)
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t)) -> Set (Some (Expr t)))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (SymExpr sym tp -> Set (Some (BoundVar sym)))
-> SymExpr sym tp -> Set (Some (BoundVar sym))
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry
      IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
variable) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: "String -> ShowS
forall a. [a] -> [a] -> [a]
++ BaseTypeRepr tp -> String
forall a. Show a => a -> String
show (Expr t tp -> BaseTypeRepr tp
forall (tp :: BaseType). Expr t tp -> BaseTypeRepr tp
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType Expr t tp
variable) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Set String -> String
forall a. Show a => a -> String
show (Set String -> String) -> Set String -> String
forall a b. (a -> b) -> a -> b
$ (Some (Expr t) -> String) -> Set (Some (Expr t)) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). Expr t tp -> String)
-> Some (Expr t) -> String
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
C.viewSome ((forall (tp :: BaseType). Expr t tp -> String)
 -> Some (Expr t) -> String)
-> (forall (tp :: BaseType). Expr t tp -> String)
-> Some (Expr t)
-> String
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (Expr t tp -> Doc Any) -> Expr t tp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr) (Set (Some (Expr t)) -> Set String)
-> Set (Some (Expr t)) -> Set String
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t))
body_vars))
    (MapF (Expr t) (FixpointEntry sym)
-> [Pair (Expr t) (FixpointEntry sym)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (FixpointEntry sym)
normal_substitution)

  MapF (Expr t) (FixpointEntry sym)
foo <- [Pair (Expr t) (FixpointEntry sym)]
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
[Pair k a] -> MapF k a
MapF.fromList ([Pair (Expr t) (FixpointEntry sym)]
 -> MapF (Expr t) (FixpointEntry sym))
-> m [Pair (Expr t) (FixpointEntry sym)]
-> m (MapF (Expr t) (FixpointEntry sym))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pair (Expr t) (FixpointEntry sym) -> m Bool)
-> [Pair (Expr t) (FixpointEntry sym)]
-> m [Pair (Expr t) (FixpointEntry sym)]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
    (\(MapF.Pair Expr t tp
variable FixpointEntry sym tp
entry) -> do
      let body_vars :: Set (Some (Expr t))
body_vars = (Some (ExprBoundVar t) -> Some (Expr t))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
C.mapSome ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
 -> Some (ExprBoundVar t) -> Some (Expr t))
-> (forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t)
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t)) -> Set (Some (Expr t)))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (SymExpr sym tp -> Set (Some (BoundVar sym)))
-> SymExpr sym tp -> Set (Some (BoundVar sym))
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry
      if Some (Expr t) -> Set (Some (Expr t)) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (Expr t tp -> Some (Expr t)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some Expr t tp
variable) Set (Some (Expr t))
body_vars then do
        let lalala :: MapF (ExprBoundVar t) (Expr t)
lalala = Identity (MapF (ExprBoundVar t) (Expr t))
-> MapF (ExprBoundVar t) (Expr t)
forall a. Identity a -> a
runIdentity (Identity (MapF (ExprBoundVar t) (Expr t))
 -> MapF (ExprBoundVar t) (Expr t))
-> Identity (MapF (ExprBoundVar t) (Expr t))
-> MapF (ExprBoundVar t) (Expr t)
forall a b. (a -> b) -> a -> b
$ (forall (tp :: BaseType).
 ExprBoundVar t tp -> Identity (Expr t tp))
-> Set (Some (ExprBoundVar t))
-> Identity (MapF (ExprBoundVar t) (Expr t))
forall k (m :: Type -> Type) (t :: Type -> Type) (a :: k -> Type)
       (v :: k -> Type).
(Monad m, Foldable t, OrdF a) =>
(forall (tp :: k). a tp -> m (v tp)) -> t (Some a) -> m (MapF a v)
MapF.fromKeysM (Expr t tp -> Identity (Expr t tp)
forall a. a -> Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr t tp -> Identity (Expr t tp))
-> (ExprBoundVar t tp -> Expr t tp)
-> ExprBoundVar t tp
-> Identity (Expr t tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t))
 -> Identity (MapF (ExprBoundVar t) (Expr t)))
-> Set (Some (ExprBoundVar t))
-> Identity (MapF (ExprBoundVar t) (Expr t))
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (SymExpr sym tp -> Set (Some (BoundVar sym)))
-> SymExpr sym tp -> Set (Some (BoundVar sym))
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry
        let foobar :: MapF (ExprBoundVar t) (Expr t)
foobar = (forall (x :: BaseType).
 FixpointEntry (ExprBuilder t st fs) x -> Expr t x)
-> MapF (ExprBoundVar t) (FixpointEntry (ExprBuilder t st fs))
-> MapF (ExprBoundVar t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (ExprBoundVar t) f -> MapF (ExprBoundVar t) g
fmapF FixpointEntry (ExprBuilder t st fs) x -> Expr t x
FixpointEntry (ExprBuilder t st fs) x
-> SymExpr (ExprBuilder t st fs) x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
forall (x :: BaseType).
FixpointEntry (ExprBuilder t st fs) x -> Expr t x
headerValue (MapF (ExprBoundVar t) (FixpointEntry (ExprBuilder t st fs))
 -> MapF (ExprBoundVar t) (Expr t))
-> MapF (ExprBoundVar t) (FixpointEntry (ExprBuilder t st fs))
-> MapF (ExprBoundVar t) (Expr t)
forall a b. (a -> b) -> a -> b
$ (forall (tp :: BaseType).
 Expr t tp -> Maybe (FixpointEntry (ExprBuilder t st fs) tp))
-> MapF (ExprBoundVar t) (Expr t)
-> MapF (ExprBoundVar t) (FixpointEntry (ExprBuilder t st fs))
forall {v} (f :: v -> Type) (g :: v -> Type) (ktp :: v -> Type).
(forall (tp :: v). f tp -> Maybe (g tp))
-> MapF ktp f -> MapF ktp g
MapF.mapMaybe (\Expr t tp
v -> Expr t tp
-> MapF (Expr t) (FixpointEntry (ExprBuilder t st fs))
-> Maybe (FixpointEntry (ExprBuilder t st fs) tp)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Maybe (a tp)
MapF.lookup Expr t tp
v MapF (Expr t) (FixpointEntry sym)
MapF (Expr t) (FixpointEntry (ExprBuilder t st fs))
normal_substitution) MapF (ExprBoundVar t) (Expr t)
lalala
        Expr t BaseBoolType
bar <- IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType))
-> IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym tp -> SymExpr sym tp -> IO (Pred sym)
forall sym (tp :: BaseType).
IsExprBuilder sym =>
sym -> SymExpr sym tp -> SymExpr sym tp -> IO (Pred sym)
forall (tp :: BaseType).
sym -> SymExpr sym tp -> SymExpr sym tp -> IO (Pred sym)
W4.isEq sym
sym (FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry) (Expr t tp -> IO (Expr t BaseBoolType))
-> IO (Expr t tp) -> IO (Expr t BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
W4.substituteBoundVars sym
sym MapF (BoundVar sym) (SymExpr sym)
MapF (ExprBoundVar t) (Expr t)
foobar (FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"la: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
variable)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"headerValue entry: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall (tp :: BaseType) ann.
SymExpr (ExprBuilder t st fs) tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr (ExprBuilder t st fs) tp -> Doc Any)
-> SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"bodyValue entry:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall (tp :: BaseType) ann.
SymExpr (ExprBuilder t st fs) tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr (ExprBuilder t st fs) tp -> Doc Any)
-> SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
entry)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"bar: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Expr t BaseBoolType -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (Expr t BaseBoolType -> Doc Any) -> Expr t BaseBoolType -> Doc Any
forall a b. (a -> b) -> a -> b
$ Expr t BaseBoolType
bar)
        if Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Expr t BaseBoolType -> Maybe Bool
forall (e :: BaseType -> Type).
IsExpr e =>
e BaseBoolType -> Maybe Bool
W4.asConstantPred Expr t BaseBoolType
bar then do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"lala"
          Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
        else do
          Expr t BaseBoolType
notbar <- IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType))
-> IO (Expr t BaseBoolType) -> m (Expr t BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
W4.notPred sym
sym Expr t BaseBoolType
Pred sym
bar
          Bool
lala <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ExprBuilder t st fs
-> LogData
-> [Expr t BaseBoolType]
-> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
    -> IO Bool)
-> IO Bool
forall t (st :: Type -> Type) fs a.
ExprBuilder t st fs
-> LogData
-> [BoolExpr t]
-> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
    -> IO a)
-> IO a
W4.runZ3InOverride sym
ExprBuilder t st fs
sym (LogData
W4.defaultLogData { W4.logVerbosity = 2 }) [Expr t BaseBoolType
notbar] ((SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
  -> IO Bool)
 -> IO Bool)
-> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
    -> IO Bool)
-> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> IO Bool)
-> (SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
    -> Bool)
-> SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) ()
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SatResult (GroundEvalFn t, Maybe (ExprRangeBindings t)) () -> Bool
forall mdl core. SatResult mdl core -> Bool
W4.isUnsat
          Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
lala (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"lalala"
          Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
lala
      else
        Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False)
    (MapF (Expr t) (FixpointEntry sym)
-> [Pair (Expr t) (FixpointEntry sym)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (FixpointEntry sym)
normal_substitution)

  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Set (Some (Expr t)) -> Set (Some (Expr t)) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint ([Some (Expr t)] -> Set (Some (Expr t))
forall a. Ord a => [a] -> Set a
Set.fromList ([Some (Expr t)] -> Set (Some (Expr t)))
-> [Some (Expr t)] -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (FixpointEntry sym) -> [Some (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Some k2]
MapF.keys MapF (Expr t) (FixpointEntry sym)
foo) ((forall (s :: BaseType). Expr t s -> Set (Some (Expr t)))
-> MapF (Expr t) (Expr t) -> Set (Some (Expr t))
forall m (e :: BaseType -> Type).
Monoid m =>
(forall (s :: BaseType). e s -> m) -> MapF (Expr t) e -> m
forall k (t :: (k -> Type) -> Type) m (e :: k -> Type).
(FoldableF t, Monoid m) =>
(forall (s :: k). e s -> m) -> t e -> m
foldMapF ((Some (ExprBoundVar t) -> Some (Expr t))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
C.mapSome ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
 -> Some (ExprBoundVar t) -> Some (Expr t))
-> (forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t)
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t)) -> Set (Some (Expr t)))
-> (Expr t s -> Set (Some (ExprBoundVar t)))
-> Expr t s
-> Set (Some (Expr t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym -> SymExpr sym s -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym) (MapF (Expr t) (Expr t) -> Set (Some (Expr t)))
-> MapF (Expr t) (Expr t) -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ (forall (x :: BaseType). FixpointEntry sym x -> Expr t x)
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (Expr t) f -> MapF (Expr t) g
fmapF FixpointEntry sym x -> Expr t x
FixpointEntry (ExprBuilder t st fs) x
-> SymExpr (ExprBuilder t st fs) x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
forall (x :: BaseType). FixpointEntry sym x -> Expr t x
bodyValue MapF (Expr t) (FixpointEntry sym)
foo)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint: uninterpretedConstantEqualitySubstitution: not disjoint"

  (MapF (Expr t) (FixpointEntry sym), MapF (Expr t) (Expr t))
-> m (MapF (Expr t) (FixpointEntry sym), MapF (Expr t) (Expr t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ( (forall (tp :: BaseType).
 Expr t tp
 -> FixpointEntry sym tp
 -> FixpointEntry sym tp
 -> Maybe (FixpointEntry sym tp))
-> (MapF (Expr t) (FixpointEntry sym)
    -> MapF (Expr t) (FixpointEntry sym))
-> (MapF (Expr t) (FixpointEntry sym)
    -> MapF (Expr t) (FixpointEntry sym))
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type) (b :: v -> Type)
       (c :: v -> Type).
OrdF k =>
(forall (tp :: v). k tp -> a tp -> b tp -> Maybe (c tp))
-> (MapF k a -> MapF k c)
-> (MapF k b -> MapF k c)
-> MapF k a
-> MapF k b
-> MapF k c
MapF.mergeWithKey (\Expr t tp
_ FixpointEntry sym tp
_ FixpointEntry sym tp
_ -> Maybe (FixpointEntry sym tp)
forall a. Maybe a
Nothing) MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall a. a -> a
id (MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall a b. a -> b -> a
const MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty) MapF (Expr t) (FixpointEntry sym)
normal_substitution MapF (Expr t) (FixpointEntry sym)
foo -- difference
    , (forall (tp :: BaseType).
 Expr t tp -> Expr t tp -> Expr t tp -> Maybe (Expr t tp))
-> (MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t))
-> (MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t))
-> MapF (Expr t) (Expr t)
-> MapF (Expr t) (Expr t)
-> MapF (Expr t) (Expr t)
forall {v} (k :: v -> Type) (a :: v -> Type) (b :: v -> Type)
       (c :: v -> Type).
OrdF k =>
(forall (tp :: v). k tp -> a tp -> b tp -> Maybe (c tp))
-> (MapF k a -> MapF k c)
-> (MapF k b -> MapF k c)
-> MapF k a
-> MapF k b
-> MapF k c
MapF.mergeWithKey (\Expr t tp
_ Expr t tp
_ -> Expr t tp -> Maybe (Expr t tp)
forall a. a -> Maybe a
Just) MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall a. a -> a
id MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall a. a -> a
id MapF (Expr t) (Expr t)
uninterpreted_constant_substitution (MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t))
-> MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall a b. (a -> b) -> a -> b
$ (forall (x :: BaseType). FixpointEntry sym x -> Expr t x)
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (Expr t) f -> MapF (Expr t) g
fmapF FixpointEntry sym x -> Expr t x
FixpointEntry (ExprBuilder t st fs) x
-> SymExpr (ExprBuilder t st fs) x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
forall (x :: BaseType). FixpointEntry sym x -> Expr t x
bodyValue MapF (Expr t) (FixpointEntry sym)
foo -- union
    )


-- -- | Given the WTO analysis results, find the nth loop.
-- --   Return the identifier of the loop header, and a list of all the blocks
-- --   that are part of the loop body. It is at this point that we check
-- --   that the loop has the necessary properties; there must be a single
-- --   entry point to the loop, and it must have a single back-edge. Otherwise,
-- --   the analysis will not work correctly.
-- computeLoopBlocks :: forall ext blocks init ret k .
--   (k ~ C.Some (C.BlockID blocks)) =>
--   C.CFG ext blocks init ret ->
--   Integer ->
--   IO (k, [k])
-- computeLoopBlocks cfg loopNum =
--   case List.genericDrop loopNum (Map.toList loop_map) of
--     [] -> fail ("Did not find " ++ show loopNum ++ " loop headers")
--     (p:_) -> do checkSingleEntry p
--                 checkSingleBackedge p
--                 return p

--  where
--   -- There should be exactly one block which is not part of the loop body that
--   -- can jump to @hd@.
--   checkSingleEntry :: (k,[k]) -> IO ()
--   checkSingleEntry (hd, body) =
--     case filter (\x -> not (elem x body) && elem hd (C.cfgSuccessors cfg x)) allReachable of
--       [_] -> return ()
--       _   -> fail "SimpleLoopInvariant feature requires a single-entry loop!"

--   -- There should be exactly on block in the loop body which can jump to @hd@.
--   checkSingleBackedge :: (k,[k]) -> IO ()
--   checkSingleBackedge (hd, body) =
--     case filter (\x -> elem hd (C.cfgSuccessors cfg x)) body of
--       [_] -> return ()
--       _   -> fail "SimpleLoopInvariant feature requires a loop with a single backedge!"

--   flattenWTOComponent = \case
--     C.SCC C.SCCData{..} ->  wtoHead : concatMap flattenWTOComponent wtoComps
--     C.Vertex v -> [v]

--   loop_map = Map.fromList $ mapMaybe
--     (\case
--       C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps)
--       C.Vertex{} -> Nothing)
--     wto

--   allReachable = concatMap flattenWTOComponent wto

--   wto = C.cfgWeakTopologicalOrdering cfg


-- | This execution feature is designed to allow a limited form of
--   verification for programs with unbounded looping structures.
--
--   It is currently highly experimental and has many limitations.
--   Most notably, it only really works properly for functions
--   consisting of a single, non-nested loop with a single exit point.
--   Moreover, the loop must have an indexing variable that counts up
--   from a starting point by a fixed stride amount.
--
--   Currently, these assumptions about the loop structure are not
--   checked.
--
--   The basic use case here is for verifying functions that loop
--   through an array of data of symbolic length.  This is done by
--   providing a \""fixpoint function\" which describes how the live
--   values in the loop at an arbitrary iteration are used to compute
--   the final values of those variables before execution leaves the
--   loop. The number and order of these variables depends on
--   internal details of the representation, so is relatively fragile.
simpleLoopFixpoint ::
  (C.IsSymInterface sym, sym ~ W4.ExprBuilder t st fs, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>
  sym ->
  C.CFG ext blocks init ret {- ^ The function we want to verify -} ->
  C.GlobalVar C.Mem {- ^ global variable representing memory -} ->
  Maybe (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), Maybe (W4.Pred sym))) ->
  IO (C.ExecutionFeature p sym ext rtp, IORef (ExecutionFeatureContext sym wptr ext))
simpleLoopFixpoint :: forall sym t (st :: Type -> Type) fs (wptr :: Nat) ext
       (blocks :: Ctx (Ctx CrucibleType)) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) p rtp.
(IsSymInterface sym, sym ~ ExprBuilder t st fs, HasPtrWidth wptr,
 KnownNat wptr, HasLLVMAnn sym, ?memOpts::MemOptions) =>
sym
-> CFG ext blocks init ret
-> GlobalVar Mem
-> Maybe
     (MapF (SymExpr sym) (FixpointEntry sym)
      -> Pred sym
      -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
-> IO
     (ExecutionFeature p sym ext rtp,
      IORef (ExecutionFeatureContext sym wptr ext))
simpleLoopFixpoint sym
sym CFG ext blocks init ret
_cfg GlobalVar Mem
mem_var Maybe
  (MapF (SymExpr sym) (FixpointEntry sym)
   -> Pred sym
   -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
maybe_fixpoint_func = do
  OptionSetting BaseIntegerType
verbSetting <- ConfigOption BaseIntegerType
-> Config -> IO (OptionSetting BaseIntegerType)
forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
W4.getOptionSetting ConfigOption BaseIntegerType
W4.verbosity (Config -> IO (OptionSetting BaseIntegerType))
-> Config -> IO (OptionSetting BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ sym -> Config
forall sym. IsExprBuilder sym => sym -> Config
W4.getConfiguration sym
sym
  Nat
_verb <- forall a. Num a => Integer -> a
fromInteger @Natural (Integer -> Nat) -> IO Integer -> IO Nat
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSetting BaseIntegerType -> IO Integer
forall (tp :: BaseType) a. Opt tp a => OptionSetting tp -> IO a
W4.getOpt OptionSetting BaseIntegerType
verbSetting

  --  let loop_map = Map.fromList $ mapMaybe
  --       (\case
  --         scc@(C.SCC _) -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps)
  --         C.Vertex{} -> Nothing)
  --       (C.cfgWeakTopologicalOrdering cfg)

  -- Doesn't really work if there are nested loops: looop datastructures will
  -- overwrite each other.  Currently no error message.

  -- Really only works for single-exit loops; need a message for that too.

  -- let flattenWTOComponent = \case
  --       C.SCC C.SCCData{..} ->  wtoHead : concatMap flattenWTOComponent wtoComps
  --       C.Vertex v -> [v]
  -- let loop_map = Map.fromList $ mapMaybe
  --       (\case
  --         C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps)
  --         C.Vertex{} -> Nothing)
  --       (C.cfgWeakTopologicalOrdering cfg)


  -- let parent_wto_component = C.parentWTOComponent $ C.cfgWeakTopologicalOrdering cfg
  -- fixpoint_state_ref <- newIORef $
  --   FrameContext
  --     { frameContextFixpointStates = MapF.empty
  --     , frameContextLoopHeaders = []
  --     , frameContextCFG = cfg
  --     , frameContextParentLoop = parent_wto_component
  --     , frameContextLoopHeaderBlockIds = Set.fromList $ Map.elems parent_wto_component
  --     }

  IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref <- ExecutionFeatureContext sym wptr ext
-> IO (IORef (ExecutionFeatureContext sym wptr ext))
forall a. a -> IO (IORef a)
newIORef (ExecutionFeatureContext sym wptr ext
 -> IO (IORef (ExecutionFeatureContext sym wptr ext)))
-> ExecutionFeatureContext sym wptr ext
-> IO (IORef (ExecutionFeatureContext sym wptr ext))
forall a b. (a -> b) -> a -> b
$
    ExecutionFeatureContext
      { executionFeatureContextFixpointStates :: FnHandleMap (SomeCallFrameContext sym wptr ext)
executionFeatureContextFixpointStates = FnHandleMap (SomeCallFrameContext sym wptr ext)
forall (f :: Ctx CrucibleType -> CrucibleType -> Type).
FnHandleMap f
C.emptyHandleMap
      , executionFeatureContextInvPreds :: [SomeSymFn sym]
executionFeatureContextInvPreds = []
      , executionFeatureContextLoopFunEquivConds :: [Pred sym]
executionFeatureContextLoopFunEquivConds = []
      }

  -- initializeCallFrameContext cfg fixpoint_state_ref

  (ExecutionFeature p sym ext rtp,
 IORef (ExecutionFeatureContext sym wptr ext))
-> IO
     (ExecutionFeature p sym ext rtp,
      IORef (ExecutionFeatureContext sym wptr ext))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((ExecutionFeature p sym ext rtp,
  IORef (ExecutionFeatureContext sym wptr ext))
 -> IO
      (ExecutionFeature p sym ext rtp,
       IORef (ExecutionFeatureContext sym wptr ext)))
-> (ExecutionFeature p sym ext rtp,
    IORef (ExecutionFeatureContext sym wptr ext))
-> IO
     (ExecutionFeature p sym ext rtp,
      IORef (ExecutionFeatureContext sym wptr ext))
forall a b. (a -> b) -> a -> b
$ (, IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref) (ExecutionFeature p sym ext rtp
 -> (ExecutionFeature p sym ext rtp,
     IORef (ExecutionFeatureContext sym wptr ext)))
-> ExecutionFeature p sym ext rtp
-> (ExecutionFeature p sym ext rtp,
    IORef (ExecutionFeatureContext sym wptr ext))
forall a b. (a -> b) -> a -> b
$ (ExecState p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeature p sym ext rtp
forall p sym ext rtp.
(ExecState p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeature p sym ext rtp
C.ExecutionFeature ((ExecState p sym ext rtp
  -> IO (ExecutionFeatureResult p sym ext rtp))
 -> ExecutionFeature p sym ext rtp)
-> (ExecState p sym ext rtp
    -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeature p sym ext rtp
forall a b. (a -> b) -> a -> b
$ \ExecState p sym ext rtp
exec_state -> do
    -- let ?logMessage = \msg -> when (_verb >= 3) $ do
    let ?logMessage = \String
msg -> do
          let h :: Handle
h = SimContext p sym ext -> Handle
forall personality sym ext.
SimContext personality sym ext -> Handle
C.printHandle (SimContext p sym ext -> Handle) -> SimContext p sym ext -> Handle
forall a b. (a -> b) -> a -> b
$ ExecState p sym ext rtp -> SimContext p sym ext
forall p sym ext r. ExecState p sym ext r -> SimContext p sym ext
C.execStateContext ExecState p sym ext rtp
exec_state
          Handle -> String -> IO ()
System.IO.hPutStrLn Handle
h String
msg
          Handle -> IO ()
System.IO.hFlush Handle
h

    -- cfg_handle <- C.cfgHandle . callFrameContextCFG <$> readIORef fixpoint_state_ref
    -- cfg_block_map <- C.cfgBlockMap . callFrameContextCFG <$> readIORef fixpoint_state_ref
    -- parent_loop_map <- callFrameContextParentLoop <$> readIORef fixpoint_state_ref
    -- loop_header_block_ids <- callFrameContextLoopHeaderBlockIds <$> readIORef fixpoint_state_ref
    -- maybe_some_loop_block_id <- callFrameContextPeek <$> readIORef fixpoint_state_ref
    SimContext p sym ext
-> (forall {bak}.
    IsSymBackend sym bak =>
    bak -> IO (ExecutionFeatureResult p sym ext rtp))
-> IO (ExecutionFeatureResult p sym ext rtp)
forall personality sym ext a.
SimContext personality sym ext
-> (forall bak. IsSymBackend sym bak => bak -> a) -> a
C.withBackend (ExecState p sym ext rtp -> SimContext p sym ext
forall p sym ext r. ExecState p sym ext r -> SimContext p sym ext
C.execStateContext ExecState p sym ext rtp
exec_state) ((forall {bak}.
  IsSymBackend sym bak =>
  bak -> IO (ExecutionFeatureResult p sym ext rtp))
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> (forall {bak}.
    IsSymBackend sym bak =>
    bak -> IO (ExecutionFeatureResult p sym ext rtp))
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ \bak
bak -> case ExecState p sym ext rtp
exec_state of
      C.RunningState (C.RunBlockStart BlockID blocks args
block_id) SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state
        | SomeCallFrameHandle CallFrameHandle init r blocks
call_frame_handle <- CallFrame sym ext blocks r args -> SomeCallFrameHandle r blocks
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (ctx :: Ctx CrucibleType).
CallFrame sym ext blocks ret ctx -> SomeCallFrameHandle ret blocks
callFrameHandle (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (CallFrame sym ext blocks r args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (CallFrame sym ext blocks r args)
-> CallFrame sym ext blocks r args
forall s a. s -> Getting a s a -> a
^. Getting
  (CallFrame sym ext blocks r args)
  (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
  (CallFrame sym ext blocks r args)
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame) -> do
          Set (Some (BlockID blocks))
loop_header_block_ids <- CallFrameHandle init r blocks
-> ExecutionFeatureContext sym wptr ext
-> Set (Some (BlockID blocks))
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Set (Some (BlockID blocks))
callFrameContextLoopHeaderBlockIds' CallFrameHandle init r blocks
call_frame_handle (ExecutionFeatureContext sym wptr ext
 -> Set (Some (BlockID blocks)))
-> IO (ExecutionFeatureContext sym wptr ext)
-> IO (Set (Some (BlockID blocks)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureContext sym wptr ext)
forall a. IORef a -> IO a
readIORef IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
          if Some (BlockID blocks) -> Set (Some (BlockID blocks)) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockID blocks args -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID blocks args
block_id) Set (Some (BlockID blocks))
loop_header_block_ids then do
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!!!SimpleLoopFixpoint: RunningState: RunBlockStart: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks args -> String
forall a. Show a => a -> String
show BlockID blocks args
block_id
            bak
-> GlobalVar Mem
-> Maybe
     (MapF (SymExpr sym) (FixpointEntry sym)
      -> Pred sym
      -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
-> CallFrameHandle init r blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
forall sym bak t (st :: Type -> Type) fs (wptr :: Nat)
       (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) p ext
       rtp (r :: CrucibleType).
(IsSymBackend sym bak, sym ~ ExprBuilder t st fs, HasPtrWidth wptr,
 KnownNat wptr, HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> GlobalVar Mem
-> Maybe
     (MapF (SymExpr sym) (FixpointEntry sym)
      -> Pred sym
      -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
advanceFixpointState bak
bak GlobalVar Mem
mem_var Maybe
  (MapF (SymExpr sym) (FixpointEntry sym)
   -> Pred sym
   -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
maybe_fixpoint_func CallFrameHandle init r blocks
call_frame_handle BlockID blocks args
block_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
          else do
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: RunningState: RunBlockStart: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks args -> String
forall a. Show a => a -> String
show BlockID blocks args
block_id
            ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp. ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNoChange

        -- | C.SomeHandle cfg_handle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)
        -- -- make sure the types match
        -- , Just Refl <- W4.testEquality
        --     (fmapFC C.blockInputs cfg_block_map)
        --     (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)
        --   -- loop map is what we computed above, is this state at a loop header
        -- , Set.member (C.Some block_id) loop_header_block_ids ->
        --     advanceFixpointState bak mem_var maybe_fixpoint_func cfg_handle block_id sim_state fixpoint_state_ref

        -- | otherwise -> do
        --     ?logMessage $ "SimpleLoopFixpoint: RunningState: RunBlockStart: " ++ show block_id
        --     return C.ExecutionFeatureNoChange

      -- TODO: maybe need to rework this, so that we are sure to capture even concrete exits from the loop.
      C.SymbolicBranchState Pred sym
branch_condition PausedFrame p sym ext rtp f
true_frame PausedFrame p sym ext rtp f
false_frame CrucibleBranchTarget f postdom_args
_target SimState p sym ext rtp f ('Just args)
sim_state
        | JustPausedFrameTgtId Some (BlockID b)
true_frame_some_block_id <- PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
forall p sym ext rtp f.
PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
pausedFrameTgtId PausedFrame p sym ext rtp f
true_frame
        , JustPausedFrameTgtId Some (BlockID b)
false_frame_some_block_id <- PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
forall p sym ext rtp f.
PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
pausedFrameTgtId PausedFrame p sym ext rtp f
false_frame
        , SomeCallFrameHandle CallFrameHandle init r b
call_frame_handle <- CallFrame sym ext b r args -> SomeCallFrameHandle r b
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (ctx :: Ctx CrucibleType).
CallFrame sym ext blocks ret ctx -> SomeCallFrameHandle ret blocks
callFrameHandle (SimState p sym ext rtp f ('Just args)
sim_state SimState p sym ext rtp f ('Just args)
-> Getting
     (CallFrame sym ext b r args)
     (SimState p sym ext rtp f ('Just args))
     (CallFrame sym ext b r args)
-> CallFrame sym ext b r args
forall s a. s -> Getting a s a -> a
^. Getting
  (CallFrame sym ext b r args)
  (SimState p sym ext rtp f ('Just args))
  (CallFrame sym ext b r args)
(CallFrame sym ext b r args
 -> Const (CallFrame sym ext b r args) (CallFrame sym ext b r args))
-> SimState p sym ext rtp (CrucibleLang b r) ('Just args)
-> Const
     (CallFrame sym ext b r args)
     (SimState p sym ext rtp (CrucibleLang b r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame) -> do
          Maybe (Some (BlockID b))
maybe_some_loop_block_id <- CallFrameHandle init r b
-> ExecutionFeatureContext sym wptr ext -> Maybe (Some (BlockID b))
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Maybe (Some (BlockID blocks))
callFrameContextPeek CallFrameHandle init r b
call_frame_handle (ExecutionFeatureContext sym wptr ext -> Maybe (Some (BlockID b)))
-> IO (ExecutionFeatureContext sym wptr ext)
-> IO (Maybe (Some (BlockID b)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureContext sym wptr ext)
forall a. IORef a -> IO a
readIORef IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
          Map (Some (BlockID b)) (Some (BlockID b))
parent_loop_map <- CallFrameHandle init r b
-> ExecutionFeatureContext sym wptr ext
-> Map (Some (BlockID b)) (Some (BlockID b))
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
callFrameContextParentLoop' CallFrameHandle init r b
call_frame_handle (ExecutionFeatureContext sym wptr ext
 -> Map (Some (BlockID b)) (Some (BlockID b)))
-> IO (ExecutionFeatureContext sym wptr ext)
-> IO (Map (Some (BlockID b)) (Some (BlockID b)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureContext sym wptr ext)
forall a. IORef a -> IO a
readIORef IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
        -- , C.SomeHandle cfg_handle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)
        -- , Just Refl <- W4.testEquality
        --     (fmapFC C.blockInputs cfg_block_map)
        --     (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)
        -- , Just (Some loop_block_id) <- maybe_some_loop_block_id
        -- , true_frame_parent_loop_id <- Map.lookup true_frame_some_block_id parent_loop_map
        -- , false_frame_parent_loop_id <- Map.lookup false_frame_some_block_id parent_loop_map
        -- , true_frame_parent_loop_id /= maybe_some_loop_block_id || false_frame_parent_loop_id /= maybe_some_loop_block_id -> do
          if| Just (Some BlockID b x
loop_block_id) <- Maybe (Some (BlockID b))
maybe_some_loop_block_id
            , Maybe (Some (BlockID b))
true_frame_parent_loop_id <- if Some (BlockID b)
true_frame_some_block_id Some (BlockID b) -> Some (BlockID b) -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockID b x -> Some (BlockID b)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID b x
loop_block_id then Some (BlockID b)
-> Map (Some (BlockID b)) (Some (BlockID b))
-> Maybe (Some (BlockID b))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Some (BlockID b)
true_frame_some_block_id Map (Some (BlockID b)) (Some (BlockID b))
parent_loop_map else Maybe (Some (BlockID b))
maybe_some_loop_block_id
            , Maybe (Some (BlockID b))
false_frame_parent_loop_id <- if Some (BlockID b)
false_frame_some_block_id Some (BlockID b) -> Some (BlockID b) -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockID b x -> Some (BlockID b)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID b x
BlockID b x
loop_block_id then Some (BlockID b)
-> Map (Some (BlockID b)) (Some (BlockID b))
-> Maybe (Some (BlockID b))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Some (BlockID b)
false_frame_some_block_id Map (Some (BlockID b)) (Some (BlockID b))
Map (Some (BlockID b)) (Some (BlockID b))
parent_loop_map else Maybe (Some (BlockID b))
maybe_some_loop_block_id
            , Maybe (Some (BlockID b))
true_frame_parent_loop_id Maybe (Some (BlockID b)) -> Maybe (Some (BlockID b)) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Some (BlockID b))
maybe_some_loop_block_id Bool -> Bool -> Bool
|| Maybe (Some (BlockID b))
false_frame_parent_loop_id Maybe (Some (BlockID b)) -> Maybe (Some (BlockID b)) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Some (BlockID b))
maybe_some_loop_block_id -> do
              ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!!!SimpleLoopFixpoint: SymbolicBranchState: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Some (BlockID b), Some (BlockID b)) -> String
forall a. Show a => a -> String
show (Some (BlockID b)
true_frame_some_block_id, Some (BlockID b)
false_frame_some_block_id)
              bak
-> CallFrameHandle init r b
-> BlockID b x
-> Pred sym
-> PausedFrame p sym ext rtp (CrucibleLang b r)
-> PausedFrame p sym ext rtp (CrucibleLang b r)
-> Maybe (Some (BlockID b))
-> Maybe (Some (BlockID b))
-> SimState p sym ext rtp (CrucibleLang b r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
forall sym bak (wptr :: Nat) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (tp :: Ctx CrucibleType) p ext rtp (r :: CrucibleType)
       (args :: Ctx CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, KnownNat wptr,
 HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> CallFrameHandle init ret blocks
-> BlockID blocks tp
-> Pred sym
-> PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> Maybe (Some (BlockID blocks))
-> Maybe (Some (BlockID blocks))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
handleSymbolicBranch
                bak
bak
                CallFrameHandle init r b
call_frame_handle
                BlockID b x
loop_block_id
                Pred sym
branch_condition
                PausedFrame p sym ext rtp f
PausedFrame p sym ext rtp (CrucibleLang b r)
true_frame
                PausedFrame p sym ext rtp f
PausedFrame p sym ext rtp (CrucibleLang b r)
false_frame
                Maybe (Some (BlockID b))
true_frame_parent_loop_id
                Maybe (Some (BlockID b))
false_frame_parent_loop_id
                SimState p sym ext rtp f ('Just args)
SimState p sym ext rtp (CrucibleLang b r) ('Just args)
sim_state
                IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
            | Bool
otherwise -> do
              ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: SymbolicBranchState: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Doc Any, Some (BlockID b), Some (BlockID b)) -> String
forall a. Show a => a -> String
show (Expr t BaseBoolType -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t BaseBoolType
Pred sym
branch_condition, Some (BlockID b)
true_frame_some_block_id, Some (BlockID b)
false_frame_some_block_id)
              ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp. ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNoChange

      C.CallState ReturnHandler ret p sym ext rtp f a
_return_handler (C.CrucibleCall BlockID blocks args
_block_id CallFrame sym ext blocks ret args
call_frame) SimState p sym ext rtp f a
_sim_state
        | C.CallFrame { _frameCFG :: ()
C._frameCFG = CFG ext blocks initialArgs ret
callee_cfg } <- CallFrame sym ext blocks ret args
call_frame -> do
          CFG ext blocks initialArgs ret
-> IORef (ExecutionFeatureContext sym wptr ext) -> IO ()
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType) sym (wptr :: Nat).
(?logMessage::String -> IO ()) =>
CFG ext blocks init ret
-> IORef (ExecutionFeatureContext sym wptr ext) -> IO ()
initializeCallFrameContext CFG ext blocks initialArgs ret
callee_cfg IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
          ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp. ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNoChange
      C.TailCallState ValueFromValue p sym ext rtp ret
_value_from_value (C.CrucibleCall BlockID blocks args
_block_id CallFrame sym ext blocks ret args
call_frame) SimState p sym ext rtp f a
_sim_state
        | C.CallFrame { _frameCFG :: ()
C._frameCFG = CFG ext blocks initialArgs ret
callee_cfg } <- CallFrame sym ext blocks ret args
call_frame -> do
          CFG ext blocks initialArgs ret
-> IORef (ExecutionFeatureContext sym wptr ext) -> IO ()
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType) sym (wptr :: Nat).
(?logMessage::String -> IO ()) =>
CFG ext blocks init ret
-> IORef (ExecutionFeatureContext sym wptr ext) -> IO ()
initializeCallFrameContext CFG ext blocks initialArgs ret
callee_cfg IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
          ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp. ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNoChange

      ExecState p sym ext rtp
_ -> ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp. ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNoChange


initializeCallFrameContext ::
  (?logMessage :: String -> IO ()) =>
  C.CFG ext blocks init ret ->
  IORef (ExecutionFeatureContext sym wptr ext) ->
  IO ()
initializeCallFrameContext :: forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType) sym (wptr :: Nat).
(?logMessage::String -> IO ()) =>
CFG ext blocks init ret
-> IORef (ExecutionFeatureContext sym wptr ext) -> IO ()
initializeCallFrameContext CFG ext blocks init ret
cfg IORef (ExecutionFeatureContext sym wptr ext)
context_ref = do
  ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: cfgHandle: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FnHandle init ret -> String
forall a. Show a => a -> String
show (CFG ext blocks init ret -> FnHandle init ret
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> FnHandle init ret
C.cfgHandle CFG ext blocks init ret
cfg)
  ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: cfg: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Some (BlockID blocks), [Some (BlockID blocks)])] -> String
forall a. Show a => a -> String
show ((forall (x :: Ctx CrucibleType).
 Block ext blocks ret x
 -> (Some (BlockID blocks), [Some (BlockID blocks)]))
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment (Block ext blocks ret) x
   -> [(Some (BlockID blocks), [Some (BlockID blocks)])]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
forall (f :: Ctx CrucibleType -> Type) a.
(forall (x :: Ctx CrucibleType). f x -> a)
-> forall (x :: Ctx (Ctx CrucibleType)). Assignment f x -> [a]
toListFC (\Block ext blocks ret x
b -> (BlockID blocks x -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some (Block ext blocks ret x -> BlockID blocks x
forall ext (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType)
       (ctx :: Ctx CrucibleType).
Block ext blocks ret ctx -> BlockID blocks ctx
C.blockID Block ext blocks ret x
b), Block ext blocks ret x -> [Some (BlockID blocks)]
forall ext (b :: Ctx (Ctx CrucibleType)) (r :: CrucibleType)
       (a :: Ctx CrucibleType).
Block ext b r a -> [Some (BlockID b)]
C.nextBlocks Block ext blocks ret x
b)) (Assignment (Block ext blocks ret) blocks
 -> [(Some (BlockID blocks), [Some (BlockID blocks)])])
-> Assignment (Block ext blocks ret) blocks
-> [(Some (BlockID blocks), [Some (BlockID blocks)])]
forall a b. (a -> b) -> a -> b
$ CFG ext blocks init ret -> Assignment (Block ext blocks ret) blocks
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> BlockMap ext blocks ret
C.cfgBlockMap CFG ext blocks init ret
cfg)
  ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: cfgWeakTopologicalOrdering: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [WTOComponent (Some (BlockID blocks))] -> String
forall a. Show a => a -> String
show (CFG ext blocks init ret -> [WTOComponent (Some (BlockID blocks))]
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> [WTOComponent (Some (BlockID blocks))]
C.cfgWeakTopologicalOrdering CFG ext blocks init ret
cfg)
  let parent_wto_component :: Map (Some (BlockID blocks)) (Some (BlockID blocks))
parent_wto_component = [WTOComponent (Some (BlockID blocks))]
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
forall n. Ord n => [WTOComponent n] -> Map n n
C.parentWTOComponent ([WTOComponent (Some (BlockID blocks))]
 -> Map (Some (BlockID blocks)) (Some (BlockID blocks)))
-> [WTOComponent (Some (BlockID blocks))]
-> Map (Some (BlockID blocks)) (Some (BlockID blocks))
forall a b. (a -> b) -> a -> b
$ CFG ext blocks init ret -> [WTOComponent (Some (BlockID blocks))]
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> [WTOComponent (Some (BlockID blocks))]
C.cfgWeakTopologicalOrdering CFG ext blocks init ret
cfg
  let call_frame_handle :: CallFrameHandle init ret blocks
call_frame_handle = FnHandle init ret
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle init ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
FnHandle init ret
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle init ret blocks
CallFrameHandle (CFG ext blocks init ret -> FnHandle init ret
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> FnHandle init ret
C.cfgHandle CFG ext blocks init ret
cfg) (Assignment (Assignment TypeRepr) blocks
 -> CallFrameHandle init ret blocks)
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle init ret blocks
forall a b. (a -> b) -> a -> b
$ (forall (x :: Ctx CrucibleType).
 Block ext blocks ret x -> Assignment TypeRepr x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment (Block ext blocks ret) x
   -> Assignment (Assignment TypeRepr) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: Ctx CrucibleType -> Type)
       (g :: Ctx CrucibleType -> Type).
(forall (x :: Ctx CrucibleType). f x -> g x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment f x -> Assignment g x
fmapFC Block ext blocks ret x -> CtxRepr x
forall ext (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType)
       (ctx :: Ctx CrucibleType).
Block ext blocks ret ctx -> CtxRepr ctx
forall (x :: Ctx CrucibleType).
Block ext blocks ret x -> Assignment TypeRepr x
C.blockInputs (Assignment (Block ext blocks ret) blocks
 -> Assignment (Assignment TypeRepr) blocks)
-> Assignment (Block ext blocks ret) blocks
-> Assignment (Assignment TypeRepr) blocks
forall a b. (a -> b) -> a -> b
$ CFG ext blocks init ret -> Assignment (Block ext blocks ret) blocks
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> BlockMap ext blocks ret
C.cfgBlockMap CFG ext blocks init ret
cfg
  IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
context_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> CallFrameContext sym wptr ext init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> CallFrameContext sym wptr ext init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddCallFrameContext CallFrameHandle init ret blocks
call_frame_handle (CallFrameContext sym wptr ext init ret blocks
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> CallFrameContext sym wptr ext init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
    CallFrameContext
      { callFrameContextFixpointStates :: MapF (BlockID blocks) (FixpointState sym wptr blocks)
callFrameContextFixpointStates = MapF (BlockID blocks) (FixpointState sym wptr blocks)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
      , callFrameContextLoopHeaders :: [Some (BlockID blocks)]
callFrameContextLoopHeaders = []
      , callFrameContextCFG :: CFG ext blocks init ret
callFrameContextCFG = CFG ext blocks init ret
cfg
      , callFrameContextParentLoop :: Map (Some (BlockID blocks)) (Some (BlockID blocks))
callFrameContextParentLoop = Map (Some (BlockID blocks)) (Some (BlockID blocks))
parent_wto_component
      , callFrameContextLoopHeaderBlockIds :: Set (Some (BlockID blocks))
callFrameContextLoopHeaderBlockIds = [Some (BlockID blocks)] -> Set (Some (BlockID blocks))
forall a. Ord a => [a] -> Set a
Set.fromList ([Some (BlockID blocks)] -> Set (Some (BlockID blocks)))
-> [Some (BlockID blocks)] -> Set (Some (BlockID blocks))
forall a b. (a -> b) -> a -> b
$ Map (Some (BlockID blocks)) (Some (BlockID blocks))
-> [Some (BlockID blocks)]
forall k a. Map k a -> [a]
Map.elems Map (Some (BlockID blocks)) (Some (BlockID blocks))
parent_wto_component
      }


initializeFixpointState ::
  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) =>
  bak ->
  C.GlobalVar C.Mem ->
  CallFrameHandle init ret blocks ->
  C.BlockID blocks args ->
  C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) ->
  IORef (ExecutionFeatureContext sym wptr ext) ->
  IO (C.ExecutionFeatureResult p sym ext rtp)
initializeFixpointState :: forall sym bak (wptr :: Nat) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType) p ext rtp (r :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, KnownNat wptr,
 HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> GlobalVar Mem
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
initializeFixpointState bak
bak GlobalVar Mem
mem_var CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
C.backendGetSym bak
bak
  FrameIdentifier
assumption_frame_identifier <- bak -> IO FrameIdentifier
forall sym bak. IsSymBackend sym bak => bak -> IO FrameIdentifier
C.pushAssumptionFrame bak
bak
  ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!!!SimpleLoopFixpoint: initializeFixpointState: block_id=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks args -> String
forall a. Show a => a -> String
show BlockID blocks args
block_id String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", assumption_frame_identifier=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FrameIdentifier -> String
forall a. Show a => a -> String
show FrameIdentifier
assumption_frame_identifier
  SymExpr sym (BaseBVType wptr)
index_var <- sym
-> SolverSymbol
-> BaseTypeRepr (BaseBVType wptr)
-> IO (SymExpr sym (BaseBVType wptr))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym -> SolverSymbol -> BaseTypeRepr tp -> IO (SymExpr sym tp)
W4.freshConstant sym
sym (String -> SolverSymbol
W4.safeSymbol String
"index_var") BaseTypeRepr (BaseBVType wptr)
forall k (f :: k -> Type) (ctx :: k). KnownRepr f ctx => f ctx
W4.knownRepr
  let mem_impl :: MemImpl sym
mem_impl = Maybe (MemImpl sym) -> MemImpl sym
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MemImpl sym) -> MemImpl sym)
-> Maybe (MemImpl sym) -> MemImpl sym
forall a b. (a -> b) -> a -> b
$ GlobalVar Mem -> SymGlobalState sym -> Maybe (RegValue sym Mem)
forall (tp :: CrucibleType) sym.
GlobalVar tp -> SymGlobalState sym -> Maybe (RegValue sym tp)
C.lookupGlobal GlobalVar Mem
mem_var (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (SymGlobalState sym)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (SymGlobalState sym)
-> SymGlobalState sym
forall s a. s -> Getting a s a -> a
^. Getting
  (SymGlobalState sym)
  (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
  (SymGlobalState sym)
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals)
  let res_mem_impl :: MemImpl sym
res_mem_impl = MemImpl sym
mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" $ C.memImplHeap mem_impl }
  IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id (FixpointState sym wptr blocks args
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
ComputeFixpoint (FixpointRecord sym wptr blocks args
 -> FixpointState sym wptr blocks args)
-> FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
forall a b. (a -> b) -> a -> b
$
    FixpointRecord
    { fixpointBlockId :: BlockID blocks args
fixpointBlockId = BlockID blocks args
block_id
    , fixpointAssumptionFrameIdentifier :: FrameIdentifier
fixpointAssumptionFrameIdentifier = FrameIdentifier
assumption_frame_identifier
    , fixpointSubstitution :: MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution = MapF (SymExpr sym) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
    , fixpointRegMap :: RegMap sym args
fixpointRegMap = SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (RegMap sym args)
-> RegMap sym args
forall s a. s -> Getting a s a -> a
^. ((CallFrame sym ext blocks r args
 -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Const
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame ((CallFrame sym ext blocks r args
  -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Const
      (RegMap sym args)
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((RegMap sym args -> Const (RegMap sym args) (RegMap sym args))
    -> CallFrame sym ext blocks r args
    -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
-> Getting
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (RegMap sym args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegMap sym args -> Const (RegMap sym args) (RegMap sym args))
-> CallFrame sym ext blocks r args
-> Const (RegMap sym args) (CallFrame sym ext blocks r args)
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (f :: Type -> Type).
Functor f =>
(RegMap sym args -> f (RegMap sym args))
-> CallFrame sym ext blocks ret args
-> f (CallFrame sym ext blocks ret args)
C.frameRegs)
    , fixpointMemSubstitution :: Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution = Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall k a. Map k a
Map.empty
    , fixpointEqualitySubstitution :: MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution = MapF (SymExpr sym) (SymExpr sym)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
    , fixpointIndex :: SymExpr sym (BaseBVType wptr)
fixpointIndex = SymExpr sym (BaseBVType wptr)
index_var
    }
  IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> Some (BlockID blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> Some (BlockID blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextPush CallFrameHandle init ret blocks
call_frame_handle (Some (BlockID blocks)
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> Some (BlockID blocks)
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$ BlockID blocks args -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some BlockID blocks args
block_id
  ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecutionFeatureResult p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp.
ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureModifiedState (ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp)
-> ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall a b. (a -> b) -> a -> b
$ RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (args :: Ctx CrucibleType).
RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
C.RunningState (BlockID blocks args -> RunningStateInfo blocks args
forall (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
BlockID blocks args -> RunningStateInfo blocks args
C.RunBlockStart BlockID blocks args
block_id) (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> ExecState p sym ext rtp)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall a b. (a -> b) -> a -> b
$
    SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& (SymGlobalState sym -> Identity (SymGlobalState sym))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals ((SymGlobalState sym -> Identity (SymGlobalState sym))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> (SymGlobalState sym -> SymGlobalState sym)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ GlobalVar Mem
-> RegValue sym Mem -> SymGlobalState sym -> SymGlobalState sym
forall (tp :: CrucibleType) sym.
GlobalVar tp
-> RegValue sym tp -> SymGlobalState sym -> SymGlobalState sym
C.insertGlobal GlobalVar Mem
mem_var RegValue sym Mem
MemImpl sym
res_mem_impl

advanceFixpointState ::
  (C.IsSymBackend sym bak, sym ~ W4.ExprBuilder t st fs, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) =>
  bak ->
  C.GlobalVar C.Mem ->
  Maybe (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), Maybe (W4.Pred sym))) ->
  CallFrameHandle init ret blocks ->
  C.BlockID blocks args ->
  C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) ->
  IORef (ExecutionFeatureContext sym wptr ext) ->
  IO (C.ExecutionFeatureResult p sym ext rtp)

advanceFixpointState :: forall sym bak t (st :: Type -> Type) fs (wptr :: Nat)
       (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) p ext
       rtp (r :: CrucibleType).
(IsSymBackend sym bak, sym ~ ExprBuilder t st fs, HasPtrWidth wptr,
 KnownNat wptr, HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> GlobalVar Mem
-> Maybe
     (MapF (SymExpr sym) (FixpointEntry sym)
      -> Pred sym
      -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
advanceFixpointState bak
bak GlobalVar Mem
mem_var Maybe
  (MapF (SymExpr sym) (FixpointEntry sym)
   -> Pred sym
   -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
maybe_fixpoint_func CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
C.backendGetSym bak
bak
  FixpointState sym wptr blocks args
fixpoint_state <- FixpointState (ExprBuilder t st fs) wptr blocks args
-> Maybe (FixpointState (ExprBuilder t st fs) wptr blocks args)
-> FixpointState (ExprBuilder t st fs) wptr blocks args
forall a. a -> Maybe a -> a
fromMaybe FixpointState (ExprBuilder t st fs) wptr blocks args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointState sym wptr blocks args
BeforeFixpoint (Maybe (FixpointState (ExprBuilder t st fs) wptr blocks args)
 -> FixpointState (ExprBuilder t st fs) wptr blocks args)
-> (ExecutionFeatureContext (ExprBuilder t st fs) wptr ext
    -> Maybe (FixpointState (ExprBuilder t st fs) wptr blocks args))
-> ExecutionFeatureContext (ExprBuilder t st fs) wptr ext
-> FixpointState (ExprBuilder t st fs) wptr blocks args
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CallFrameHandle init ret blocks
-> BlockID blocks args
-> ExecutionFeatureContext (ExprBuilder t st fs) wptr ext
-> Maybe (FixpointState (ExprBuilder t st fs) wptr blocks args)
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> ExecutionFeatureContext sym wptr ext
-> Maybe (FixpointState sym wptr blocks args)
callFrameContextLookup' CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id (ExecutionFeatureContext sym wptr ext
 -> FixpointState sym wptr blocks args)
-> IO (ExecutionFeatureContext sym wptr ext)
-> IO (FixpointState sym wptr blocks args)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureContext sym wptr ext)
forall a. IORef a -> IO a
readIORef IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
  case FixpointState sym wptr blocks args
fixpoint_state of
    FixpointState sym wptr blocks args
BeforeFixpoint -> do
      ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: RunningState: BeforeFixpoint -> ComputeFixpoint"
      (ProofGoal
   (CrucibleAssumptions (Expr t))
   (LabeledPred (Expr t BaseBoolType) SimError)
 -> IO ())
-> [ProofGoal
      (CrucibleAssumptions (Expr t))
      (LabeledPred (Expr t BaseBoolType) SimError)]
-> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ProofGoal
  (CrucibleAssumptions (Expr t))
  (LabeledPred (Expr t BaseBoolType) SimError)
g -> Doc Any -> IO ()
forall a. Show a => a -> IO ()
print (Doc Any -> IO ()) -> IO (Doc Any) -> IO ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< sym -> ProofObligation sym -> IO (Doc Any)
forall sym ann.
IsExprBuilder sym =>
sym -> ProofObligation sym -> IO (Doc ann)
C.ppProofObligation sym
sym ProofGoal
  (CrucibleAssumptions (Expr t))
  (LabeledPred (Expr t BaseBoolType) SimError)
ProofObligation sym
g) ([ProofGoal
    (CrucibleAssumptions (Expr t))
    (LabeledPred (Expr t BaseBoolType) SimError)]
 -> IO ())
-> IO
     [ProofGoal
        (CrucibleAssumptions (Expr t))
        (LabeledPred (Expr t BaseBoolType) SimError)]
-> IO ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([ProofGoal
   (CrucibleAssumptions (Expr t))
   (LabeledPred (Expr t BaseBoolType) SimError)]
-> (Goals
      (CrucibleAssumptions (Expr t))
      (LabeledPred (Expr t BaseBoolType) SimError)
    -> [ProofGoal
          (CrucibleAssumptions (Expr t))
          (LabeledPred (Expr t BaseBoolType) SimError)])
-> Maybe
     (Goals
        (CrucibleAssumptions (Expr t))
        (LabeledPred (Expr t BaseBoolType) SimError))
-> [ProofGoal
      (CrucibleAssumptions (Expr t))
      (LabeledPred (Expr t BaseBoolType) SimError)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Goals
  (CrucibleAssumptions (Expr t))
  (LabeledPred (Expr t BaseBoolType) SimError)
-> [ProofGoal
      (CrucibleAssumptions (Expr t))
      (LabeledPred (Expr t BaseBoolType) SimError)]
forall asmp goal.
Monoid asmp =>
Goals asmp goal -> [ProofGoal asmp goal]
C.goalsToList (Maybe
   (Goals
      (CrucibleAssumptions (Expr t))
      (LabeledPred (Expr t BaseBoolType) SimError))
 -> [ProofGoal
       (CrucibleAssumptions (Expr t))
       (LabeledPred (Expr t BaseBoolType) SimError)])
-> IO
     (Maybe
        (Goals
           (CrucibleAssumptions (Expr t))
           (LabeledPred (Expr t BaseBoolType) SimError)))
-> IO
     [ProofGoal
        (CrucibleAssumptions (Expr t))
        (LabeledPred (Expr t BaseBoolType) SimError)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> bak -> IO (ProofObligations (ExprBuilder t st fs))
forall sym bak.
IsSymBackend sym bak =>
bak -> IO (ProofObligations sym)
C.getProofObligations bak
bak)
      bak
-> GlobalVar Mem
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
forall sym bak (wptr :: Nat) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType) p ext rtp (r :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, KnownNat wptr,
 HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> GlobalVar Mem
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
initializeFixpointState bak
bak GlobalVar Mem
mem_var CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref

    ComputeFixpoint FixpointRecord sym wptr blocks args
fixpoint_record -> do
        ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: RunningState: ComputeFixpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks args -> String
forall a. Show a => a -> String
show BlockID blocks args
block_id
        Set (Some (Expr t))
proof_goals_and_assumptions_vars <- (Some (BoundVar (ExprBuilder t st fs)) -> Some (Expr t))
-> Set (Some (BoundVar (ExprBuilder t st fs)))
-> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType).
 BoundVar (ExprBuilder t st fs) tp -> Expr t tp)
-> Some (BoundVar (ExprBuilder t st fs)) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
mapSome ((forall (tp :: BaseType).
  BoundVar (ExprBuilder t st fs) tp -> Expr t tp)
 -> Some (BoundVar (ExprBuilder t st fs)) -> Some (Expr t))
-> (forall (tp :: BaseType).
    BoundVar (ExprBuilder t st fs) tp -> Expr t tp)
-> Some (BoundVar (ExprBuilder t st fs))
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (BoundVar (ExprBuilder t st fs)))
 -> Set (Some (Expr t)))
-> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
-> IO (Set (Some (Expr t)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
          (Set (Some (BoundVar (ExprBuilder t st fs)))
-> Set (Some (BoundVar (ExprBuilder t st fs)))
-> Set (Some (BoundVar (ExprBuilder t st fs)))
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set (Some (BoundVar (ExprBuilder t st fs)))
 -> Set (Some (BoundVar (ExprBuilder t st fs)))
 -> Set (Some (BoundVar (ExprBuilder t st fs))))
-> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
-> IO
     (Set (Some (BoundVar (ExprBuilder t st fs)))
      -> Set (Some (BoundVar (ExprBuilder t st fs))))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> bak -> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
forall sym bak.
IsSymBackend sym bak =>
bak -> IO (Set (Some (BoundVar sym)))
C.proofObligationsUninterpConstants bak
bak IO
  (Set (Some (BoundVar (ExprBuilder t st fs)))
   -> Set (Some (BoundVar (ExprBuilder t st fs))))
-> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
-> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> bak -> IO (Set (Some (BoundVar (ExprBuilder t st fs))))
forall sym bak.
IsSymBackend sym bak =>
bak -> IO (Set (Some (BoundVar sym)))
C.pathConditionUninterpConstants bak
bak)
        (CrucibleAssumptions (SymExpr (ExprBuilder t st fs))
frame_assumptions, ProofObligations (ExprBuilder t st fs)
_) <- bak
-> FrameIdentifier
-> IO
     (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)),
      ProofObligations (ExprBuilder t st fs))
forall sym bak.
IsSymBackend sym bak =>
bak
-> FrameIdentifier -> IO (Assumptions sym, ProofObligations sym)
C.popAssumptionFrameAndObligations bak
bak (FrameIdentifier
 -> IO
      (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)),
       ProofObligations (ExprBuilder t st fs)))
-> FrameIdentifier
-> IO
     (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)),
      ProofObligations (ExprBuilder t st fs))
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args -> FrameIdentifier
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> FrameIdentifier
fixpointAssumptionFrameIdentifier FixpointRecord sym wptr blocks args
fixpoint_record
        Expr t BaseBoolType
loop_condition <- sym -> Assumptions sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Assumptions sym -> IO (Pred sym)
C.assumptionsPred sym
sym Assumptions sym
CrucibleAssumptions (SymExpr (ExprBuilder t st fs))
frame_assumptions

        -- widen the inductive condition
        (Assignment (RegEntry sym) args
join_reg_map, MapF (Expr t) (FixpointEntry sym)
join_substitution) <- FixpointMonad sym (Assignment (RegEntry sym) args)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO
     (Assignment (RegEntry sym) args,
      MapF (SymExpr sym) (FixpointEntry sym))
forall sym a.
FixpointMonad sym a
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO (a, MapF (SymExpr sym) (FixpointEntry sym))
runFixpointMonad
          (sym
-> Assignment (RegEntry sym) args
-> Assignment (RegEntry sym) args
-> FixpointMonad sym (Assignment (RegEntry sym) args)
forall sym (ctx :: Ctx CrucibleType).
(?logMessage::String -> IO (), IsSymInterface sym) =>
sym
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
-> FixpointMonad sym (Assignment (RegEntry sym) ctx)
joinRegEntries sym
sym
            (RegMap sym args -> Assignment (RegEntry sym) args
forall sym (ctx :: Ctx CrucibleType).
RegMap sym ctx -> Assignment (RegEntry sym) ctx
C.regMap (RegMap sym args -> Assignment (RegEntry sym) args)
-> RegMap sym args -> Assignment (RegEntry sym) args
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args -> RegMap sym args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> RegMap sym args
fixpointRegMap FixpointRecord sym wptr blocks args
fixpoint_record)
            (RegMap sym args -> Assignment (RegEntry sym) args
forall sym (ctx :: Ctx CrucibleType).
RegMap sym ctx -> Assignment (RegEntry sym) ctx
C.regMap (RegMap sym args -> Assignment (RegEntry sym) args)
-> RegMap sym args -> Assignment (RegEntry sym) args
forall a b. (a -> b) -> a -> b
$ SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (RegMap sym args)
-> RegMap sym args
forall s a. s -> Getting a s a -> a
^. ((CallFrame sym ext blocks r args
 -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Const
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame ((CallFrame sym ext blocks r args
  -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Const
      (RegMap sym args)
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((RegMap sym args -> Const (RegMap sym args) (RegMap sym args))
    -> CallFrame sym ext blocks r args
    -> Const (RegMap sym args) (CallFrame sym ext blocks r args))
-> Getting
     (RegMap sym args)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (RegMap sym args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegMap sym args -> Const (RegMap sym args) (RegMap sym args))
-> CallFrame sym ext blocks r args
-> Const (RegMap sym args) (CallFrame sym ext blocks r args)
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (f :: Type -> Type).
Functor f =>
(RegMap sym args -> f (RegMap sym args))
-> CallFrame sym ext blocks ret args
-> f (CallFrame sym ext blocks ret args)
C.frameRegs))) (MapF (SymExpr sym) (FixpointEntry sym)
 -> IO
      (Assignment (RegEntry sym) args,
       MapF (SymExpr sym) (FixpointEntry sym)))
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO
     (Assignment (RegEntry sym) args,
      MapF (SymExpr sym) (FixpointEntry sym))
forall a b. (a -> b) -> a -> b
$
          FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution FixpointRecord sym wptr blocks args
fixpoint_record

        let body_mem_impl :: MemImpl sym
body_mem_impl = Maybe (MemImpl sym) -> MemImpl sym
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MemImpl sym) -> MemImpl sym)
-> Maybe (MemImpl sym) -> MemImpl sym
forall a b. (a -> b) -> a -> b
$ GlobalVar Mem -> SymGlobalState sym -> Maybe (RegValue sym Mem)
forall (tp :: CrucibleType) sym.
GlobalVar tp -> SymGlobalState sym -> Maybe (RegValue sym tp)
C.lookupGlobal GlobalVar Mem
mem_var (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (SymGlobalState sym)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (SymGlobalState sym)
-> SymGlobalState sym
forall s a. s -> Getting a s a -> a
^. Getting
  (SymGlobalState sym)
  (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
  (SymGlobalState sym)
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals)
        let (MemImpl sym
header_mem_impl, MemAllocs sym
mem_allocs, MemWrites sym
mem_writes) = MemImpl sym -> (MemImpl sym, MemAllocs sym, MemWrites sym)
forall sym.
IsSymInterface sym =>
MemImpl sym -> (MemImpl sym, MemAllocs sym, MemWrites sym)
dropMemStackFrame MemImpl sym
body_mem_impl
        Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (MemAllocs sym -> Int
forall sym. MemAllocs sym -> Int
C.sizeMemAllocs MemAllocs sym
mem_allocs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> IO ()
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint: unsupported memory allocation in loop body."

        -- widen the memory
        Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution_candidate <- sym
-> MemImpl sym
-> MemWrites sym
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall sym (wptr :: Nat).
(IsSymInterface sym, HasPtrWidth wptr) =>
sym
-> MemImpl sym
-> MemWrites sym
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
joinMem sym
sym MemImpl sym
header_mem_impl MemWrites sym
mem_writes

        -- check that the mem substitution always computes the same footprint on every iteration (!?!)
        Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution <- if Map (MemLocation sym wptr) (MemFixpointEntry sym wptr) -> Bool
forall k a. Map k a -> Bool
Map.null (FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record)
          then Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution_candidate
          else if Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [MemLocation sym wptr]
forall k a. Map k a -> [k]
Map.keys Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution_candidate [MemLocation sym wptr] -> [MemLocation sym wptr] -> Bool
forall a. Eq a => a -> a -> Bool
== Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [MemLocation sym wptr]
forall k a. Map k a -> [k]
Map.keys (FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record)
            then Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
 -> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)))
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record
            else String
-> IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint: unsupported memory writes change"

        FrameIdentifier
assumption_frame_identifier <- bak -> IO FrameIdentifier
forall sym bak. IsSymBackend sym bak => bak -> IO FrameIdentifier
C.pushAssumptionFrame bak
bak

        -- check if we are done; if we did not introduce any new variables, we don't have to widen any more
        if MapF (Expr t) (FixpointEntry sym) -> [Some (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Some k2]
MapF.keys MapF (Expr t) (FixpointEntry sym)
join_substitution [Some (Expr t)] -> [Some (Expr t)] -> Bool
forall a. Eq a => a -> a -> Bool
== MapF (Expr t) (FixpointEntry sym) -> [Some (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Some k2]
MapF.keys (FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution FixpointRecord sym wptr blocks args
fixpoint_record) Bool -> Bool -> Bool
&& Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [MemLocation sym wptr]
forall k a. Map k a -> [k]
Map.keys Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution [MemLocation sym wptr] -> [MemLocation sym wptr] -> Bool
forall a. Eq a => a -> a -> Bool
== Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> [MemLocation sym wptr]
forall k a. Map k a -> [k]
Map.keys (FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record)

          -- we found the fixpoint, get ready to wrap up
          then do
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"SimpleLoopFixpoint: RunningState: ComputeFixpoint -> CheckFixpoint"

            -- we have delayed populating the main substitution map with
            --  memory variables, so we have to do that now

            MapF (Expr t) (Expr t)
header_mem_substitution <- bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
loadMemJoinVariables bak
bak MemImpl sym
header_mem_impl (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
 -> IO (MapF (SymExpr sym) (SymExpr sym)))
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall a b. (a -> b) -> a -> b
$
              FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record
            MapF (Expr t) (Expr t)
body_mem_substitution <- bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
loadMemJoinVariables bak
bak MemImpl sym
body_mem_impl (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
 -> IO (MapF (SymExpr sym) (SymExpr sym)))
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall a b. (a -> b) -> a -> b
$
              FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record

            -- drop variables that don't appear along some back edge
            let union_substitution' :: MapF (SymExpr sym) (FixpointEntry sym)
union_substitution' = sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall sym.
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
filterSubstitution sym
sym (MapF (SymExpr sym) (FixpointEntry sym)
 -> MapF (SymExpr sym) (FixpointEntry sym))
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall a b. (a -> b) -> a -> b
$
                  MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
MapF k a -> MapF k a -> MapF k a
MapF.union MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
join_substitution (MapF (SymExpr sym) (FixpointEntry sym)
 -> MapF (SymExpr sym) (FixpointEntry sym))
-> MapF (SymExpr sym) (FixpointEntry sym)
-> MapF (SymExpr sym) (FixpointEntry sym)
forall a b. (a -> b) -> a -> b
$
                  -- this implements zip, because the two maps have the same keys
                  (forall (tp :: BaseType).
 Expr t tp
 -> Expr t tp -> Expr t tp -> Maybe (FixpointEntry sym tp))
-> MapF (Expr t) (Expr t)
-> MapF (Expr t) (Expr t)
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (a :: v -> Type) (b :: v -> Type)
       (c :: v -> Type).
OrdF k =>
(forall (tp :: v). k tp -> a tp -> b tp -> Maybe (c tp))
-> MapF k a -> MapF k b -> MapF k c
MapF.intersectWithKeyMaybe
                    (\Expr t tp
_k Expr t tp
x Expr t tp
y -> FixpointEntry sym tp -> Maybe (FixpointEntry sym tp)
forall a. a -> Maybe a
Just (FixpointEntry sym tp -> Maybe (FixpointEntry sym tp))
-> FixpointEntry sym tp -> Maybe (FixpointEntry sym tp)
forall a b. (a -> b) -> a -> b
$ FixpointEntry{ headerValue :: SymExpr sym tp
headerValue = Expr t tp
SymExpr sym tp
x, bodyValue :: SymExpr sym tp
bodyValue = Expr t tp
SymExpr sym tp
y })
                    MapF (Expr t) (Expr t)
header_mem_substitution
                    MapF (Expr t) (Expr t)
body_mem_substitution
            MapF (Expr t) (Expr t)
loop_index_linear_substitution <- sym
-> SymBV sym wptr
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO (MapF (SymExpr sym) (SymExpr sym))
forall sym (wptr :: Nat) (m :: Type -> Type).
(IsSymInterface sym, HasPtrWidth wptr, MonadIO m) =>
sym
-> SymBV sym wptr
-> MapF (SymExpr sym) (FixpointEntry sym)
-> m (MapF (SymExpr sym) (SymExpr sym))
loopIndexLinearSubstitution sym
sym (FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record) MapF (SymExpr sym) (FixpointEntry sym)
union_substitution'

            let union_substitution :: MapF (Expr t) (FixpointEntry sym)
union_substitution = (forall (tp :: BaseType).
 Expr t tp -> FixpointEntry sym tp -> Bool)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (f :: v -> Type).
(forall (tp :: v). k tp -> f tp -> Bool) -> MapF k f -> MapF k f
MapF.filterWithKey
                  (\Expr t tp
variable FixpointEntry sym tp
_entry -> Expr t tp -> MapF (Expr t) (Expr t) -> Bool
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Bool
MapF.notMember Expr t tp
variable MapF (Expr t) (Expr t)
loop_index_linear_substitution)
                  MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
union_substitution'
            -- try to unify widening variables that have the same values
            (MapF (Expr t) (FixpointEntry sym)
normal_substitution', MapF (Expr t) (Expr t)
equality_substitution') <- sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> IO
     (MapF (SymExpr sym) (FixpointEntry sym),
      MapF (SymExpr sym) (SymExpr sym))
forall sym t (st :: Type -> Type) fs (m :: Type -> Type).
(IsSymInterface sym, sym ~ ExprBuilder t st fs, MonadIO m,
 MonadFail m, ?logMessage::String -> IO ()) =>
sym
-> MapF (SymExpr sym) (FixpointEntry sym)
-> m (MapF (SymExpr sym) (FixpointEntry sym),
      MapF (SymExpr sym) (SymExpr sym))
uninterpretedConstantEqualitySubstitution sym
sym MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
union_substitution

            Expr t (BaseBVType wptr)
zero_bv <- sym -> NatRepr wptr -> IO (SymBV sym wptr)
forall (w :: Nat) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
W4.bvZero sym
sym NatRepr wptr
forall (n :: Nat). KnownNat n => NatRepr n
knownNat
            Expr t (BaseBVType wptr)
one_bv <- sym -> NatRepr wptr -> IO (SymBV sym wptr)
forall (w :: Nat) sym.
(1 <= w, IsExprBuilder sym) =>
sym -> NatRepr w -> IO (SymBV sym w)
W4.bvOne sym
sym NatRepr wptr
forall (n :: Nat). KnownNat n => NatRepr n
knownNat
            Expr t (BaseBVType wptr)
add_index_one <- sym -> SymBV sym wptr -> SymBV sym wptr -> IO (SymBV sym wptr)
forall (w :: Nat).
(1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
forall sym (w :: Nat).
(IsExprBuilder sym, 1 <= w) =>
sym -> SymBV sym w -> SymBV sym w -> IO (SymBV sym w)
W4.bvAdd sym
sym (FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record) Expr t (BaseBVType wptr)
SymBV sym wptr
one_bv
            let normal_substitution :: MapF (Expr t) (FixpointEntry sym)
normal_substitution = Expr t (BaseBVType wptr)
-> FixpointEntry sym (BaseBVType wptr)
-> MapF (Expr t) (FixpointEntry sym)
-> MapF (Expr t) (FixpointEntry sym)
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> a tp -> MapF k a -> MapF k a
MapF.insert
                  (FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record)
                  FixpointEntry
                    { headerValue :: SymBV sym wptr
headerValue = Expr t (BaseBVType wptr)
SymBV sym wptr
zero_bv
                    , bodyValue :: SymBV sym wptr
bodyValue = Expr t (BaseBVType wptr)
SymBV sym wptr
add_index_one
                    }
                  MapF (Expr t) (FixpointEntry sym)
normal_substitution'
            let equality_substitution :: MapF (Expr t) (Expr t)
equality_substitution = MapF (Expr t) (Expr t)
-> MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
MapF k a -> MapF k a -> MapF k a
MapF.union MapF (Expr t) (Expr t)
equality_substitution' MapF (Expr t) (Expr t)
loop_index_linear_substitution

            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"loop_index_linear_substitution: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Doc Any, Doc Any)] -> String
forall a. Show a => a -> String
show ((Pair (Expr t) (Expr t) -> (Doc Any, Doc Any))
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MapF.Pair Expr t tp
x Expr t tp
y) -> (Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
x, Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
y)) ([Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)])
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (Expr t) -> [Pair (Expr t) (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (Expr t)
loop_index_linear_substitution)
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"normal_substitution: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Doc Any, Doc Any)] -> String
forall a. Show a => a -> String
show ((Pair (Expr t) (FixpointEntry sym) -> (Doc Any, Doc Any))
-> [Pair (Expr t) (FixpointEntry sym)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MapF.Pair Expr t tp
x FixpointEntry sym tp
y) -> (Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
x, SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall (tp :: BaseType) ann.
SymExpr (ExprBuilder t st fs) tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr (SymExpr (ExprBuilder t st fs) tp -> Doc Any)
-> SymExpr (ExprBuilder t st fs) tp -> Doc Any
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym tp
FixpointEntry (ExprBuilder t st fs) tp
y)) ([Pair (Expr t) (FixpointEntry sym)] -> [(Doc Any, Doc Any)])
-> [Pair (Expr t) (FixpointEntry sym)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (FixpointEntry sym)
-> [Pair (Expr t) (FixpointEntry sym)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (FixpointEntry sym)
normal_substitution)
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"equality_substitution: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Doc Any, Doc Any)] -> String
forall a. Show a => a -> String
show ((Pair (Expr t) (Expr t) -> (Doc Any, Doc Any))
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MapF.Pair Expr t tp
x Expr t tp
y) -> (Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
x, Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
y)) ([Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)])
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (Expr t) -> [Pair (Expr t) (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (Expr t)
equality_substitution)

            -- unify widening variables in the register subst
            let res_reg_map :: Assignment (RegEntry sym) args
res_reg_map = sym
-> MapF (SymExpr sym) (SymExpr sym)
-> Assignment (RegEntry sym) args
-> Assignment (RegEntry sym) args
forall sym (ctx :: Ctx CrucibleType).
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (SymExpr sym)
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
applySubstitutionRegEntries sym
sym MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
equality_substitution Assignment (RegEntry sym) args
join_reg_map

            -- unify widening varialbes in the memory subst
            MemImpl sym
res_mem_impl <- bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
storeMemJoinVariables
              bak
bak
              (MemImpl sym
header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) })
              Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution
              MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
equality_substitution

            let body_values_vars :: Set (Some (Expr t))
body_values_vars = (Some (FixpointEntry sym) -> Set (Some (Expr t)))
-> [Some (FixpointEntry sym)] -> Set (Some (Expr t))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall (tp :: BaseType).
 FixpointEntry sym tp -> Set (Some (Expr t)))
-> Some (FixpointEntry sym) -> Set (Some (Expr t))
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome ((forall (tp :: BaseType).
  FixpointEntry sym tp -> Set (Some (Expr t)))
 -> Some (FixpointEntry sym) -> Set (Some (Expr t)))
-> (forall (tp :: BaseType).
    FixpointEntry sym tp -> Set (Some (Expr t)))
-> Some (FixpointEntry sym)
-> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ (Some (ExprBoundVar t) -> Some (Expr t))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
mapSome ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
 -> Some (ExprBoundVar t) -> Some (Expr t))
-> (forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t)
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t)) -> Set (Some (Expr t)))
-> (FixpointEntry sym tp -> Set (Some (ExprBoundVar t)))
-> FixpointEntry sym tp
-> Set (Some (Expr t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (Expr t tp -> Set (Some (ExprBoundVar t)))
-> (FixpointEntry sym tp -> Expr t tp)
-> FixpointEntry sym tp
-> Set (Some (ExprBoundVar t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixpointEntry sym tp -> Expr t tp
FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue) ([Some (FixpointEntry sym)] -> Set (Some (Expr t)))
-> [Some (FixpointEntry sym)] -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$
                  MapF (Expr t) (FixpointEntry sym) -> [Some (FixpointEntry sym)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Some a]
MapF.elems MapF (Expr t) (FixpointEntry sym)
normal_substitution
            let header_values_vars :: Set (Some (Expr t))
header_values_vars = (Some (FixpointEntry sym) -> Set (Some (Expr t)))
-> [Some (FixpointEntry sym)] -> Set (Some (Expr t))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall (tp :: BaseType).
 FixpointEntry sym tp -> Set (Some (Expr t)))
-> Some (FixpointEntry sym) -> Set (Some (Expr t))
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome ((forall (tp :: BaseType).
  FixpointEntry sym tp -> Set (Some (Expr t)))
 -> Some (FixpointEntry sym) -> Set (Some (Expr t)))
-> (forall (tp :: BaseType).
    FixpointEntry sym tp -> Set (Some (Expr t)))
-> Some (FixpointEntry sym)
-> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$ (Some (ExprBoundVar t) -> Some (Expr t))
-> Set (Some (ExprBoundVar t)) -> Set (Some (Expr t))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t) -> Some (Expr t)
forall {k} (f :: k -> Type) (g :: k -> Type).
(forall (tp :: k). f tp -> g tp) -> Some f -> Some g
mapSome ((forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
 -> Some (ExprBoundVar t) -> Some (Expr t))
-> (forall (tp :: BaseType). ExprBoundVar t tp -> Expr t tp)
-> Some (ExprBoundVar t)
-> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ sym -> BoundVar sym tp -> SymExpr sym tp
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym) (Set (Some (ExprBoundVar t)) -> Set (Some (Expr t)))
-> (FixpointEntry sym tp -> Set (Some (ExprBoundVar t)))
-> FixpointEntry sym tp
-> Set (Some (Expr t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym (Expr t tp -> Set (Some (ExprBoundVar t)))
-> (FixpointEntry sym tp -> Expr t tp)
-> FixpointEntry sym tp
-> Set (Some (ExprBoundVar t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixpointEntry sym tp -> Expr t tp
FixpointEntry (ExprBuilder t st fs) tp
-> SymExpr (ExprBuilder t st fs) tp
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
headerValue) ([Some (FixpointEntry sym)] -> Set (Some (Expr t)))
-> [Some (FixpointEntry sym)] -> Set (Some (Expr t))
forall a b. (a -> b) -> a -> b
$
                  MapF (Expr t) (FixpointEntry sym) -> [Some (FixpointEntry sym)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Some a]
MapF.elems MapF (Expr t) (FixpointEntry sym)
normal_substitution
            -- let all_vars = Set.union proof_goals_and_assumptions_vars $ Set.union body_values_vars header_values_vars
            let all_vars' :: Set (Some (Expr t))
all_vars' = Some (Expr t) -> Set (Some (Expr t)) -> Set (Some (Expr t))
forall a. Ord a => a -> Set a -> Set a
Set.insert (Expr t (BaseBVType wptr) -> Some (Expr t)
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some (Expr t (BaseBVType wptr) -> Some (Expr t))
-> Expr t (BaseBVType wptr) -> Some (Expr t)
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record) Set (Some (Expr t))
proof_goals_and_assumptions_vars
            let all_vars :: Set (Some (Expr t))
all_vars = (Some (Expr t) -> Bool)
-> Set (Some (Expr t)) -> Set (Some (Expr t))
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
                  (\(Some Expr t x
variable) -> Expr t x -> MapF (Expr t) (Expr t) -> Bool
forall {v} (k :: v -> Type) (tp :: v) (a :: v -> Type).
OrdF k =>
k tp -> MapF k a -> Bool
MapF.notMember Expr t x
variable MapF (Expr t) (Expr t)
equality_substitution)
                  Set (Some (Expr t))
all_vars'
            -- let some_uninterpreted_constants = Ctx.fromList $ Set.toList all_vars
            let filtered_vars :: Set (Some (Expr t))
filtered_vars =  (Some (Expr t) -> Bool)
-> Set (Some (Expr t)) -> Set (Some (Expr t))
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
                  (\(Some Expr t x
variable) ->
                    Bool -> Bool
not (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"cundefined_" (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Expr t x -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t x
variable)
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"calign_amount" (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Expr t x -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t x
variable)
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"cnoSatisfyingWrite" (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Expr t x -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t x
variable))
                  Set (Some (Expr t))
all_vars
            let some_uninterpreted_constants :: Some (Assignment (Expr t))
some_uninterpreted_constants = [Some (Expr t)] -> Some (Assignment (Expr t))
forall {k} (f :: k -> Type). [Some f] -> Some (Assignment f)
Ctx.fromList ([Some (Expr t)] -> Some (Assignment (Expr t)))
-> [Some (Expr t)] -> Some (Assignment (Expr t))
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t)) -> [Some (Expr t)]
forall a. Set a -> [a]
Set.toList Set (Some (Expr t))
filtered_vars
            -- let implicit_vars = Set.filter
            --       (\(Some variable) ->
            --         not (List.isPrefixOf "creg_join_var" $ show $ W4.printSymExpr variable)
            --         && not (List.isPrefixOf "cmem_join_var" $ show $ W4.printSymExpr variable)
            --         && not (List.isPrefixOf "cundefined_" $ show $ W4.printSymExpr variable)
            --         && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable)
            --         && not (List.isPrefixOf "cnoSatisfyingWrite" $ show $ W4.printSymExpr variable))
            --       all_vars
            SomeSymFn sym
some_inv_pred <- case Some (Assignment (Expr t))
some_uninterpreted_constants of
              Some Assignment (Expr t) x
uninterpreted_constants -> do
                ExprSymFn t x BaseBoolType
inv_pred <- sym
-> SolverSymbol
-> Assignment BaseTypeRepr x
-> BaseTypeRepr BaseBoolType
-> IO (SymFn sym x BaseBoolType)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
IsSymExprBuilder sym =>
sym
-> SolverSymbol
-> Assignment BaseTypeRepr args
-> BaseTypeRepr ret
-> IO (SymFn sym args ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
sym
-> SolverSymbol
-> Assignment BaseTypeRepr args
-> BaseTypeRepr ret
-> IO (SymFn sym args ret)
W4.freshTotalUninterpFn
                  sym
sym
                  (String -> SolverSymbol
W4.safeSymbol String
"inv")
                  ((forall (x :: BaseType). Expr t x -> BaseTypeRepr x)
-> forall (x :: Ctx BaseType).
   Assignment (Expr t) x -> Assignment BaseTypeRepr x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> forall (x :: Ctx BaseType). Assignment f x -> Assignment g x
fmapFC Expr t x -> BaseTypeRepr x
forall (x :: BaseType). Expr t x -> BaseTypeRepr x
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType Assignment (Expr t) x
uninterpreted_constants)
                  BaseTypeRepr BaseBoolType
W4.BaseBoolRepr

                ProgramLoc
loc <- sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
W4.getCurrentProgramLoc sym
sym

                Expr t BaseBoolType
header_inv <- sym
-> SymFn sym x BaseBoolType
-> Assignment (SymExpr sym) x
-> IO (Pred sym)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
IsSymExprBuilder sym =>
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
W4.applySymFn sym
sym SymFn sym x BaseBoolType
ExprSymFn t x BaseBoolType
inv_pred (Assignment (SymExpr sym) x -> IO (Pred sym))
-> Assignment (SymExpr sym) x -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$
                  MapF (Expr t) (Expr t)
-> Assignment (Expr t) x -> Assignment (Expr t) x
forall {k} {l} (k :: k -> Type) (f :: (k -> Type) -> l -> Type)
       (l :: l).
(OrdF k, FunctorFC f) =>
MapF k k -> f k l -> f k l
applySubstitutionFC ((forall (x :: BaseType). FixpointEntry sym x -> Expr t x)
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (Expr t) f -> MapF (Expr t) g
fmapF FixpointEntry sym x -> Expr t x
FixpointEntry (ExprBuilder t st fs) x
-> SymExpr (ExprBuilder t st fs) x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
forall (x :: BaseType). FixpointEntry sym x -> Expr t x
headerValue MapF (Expr t) (FixpointEntry sym)
normal_substitution) Assignment (Expr t) x
uninterpreted_constants
                bak -> Assertion (ExprBuilder t st fs) -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assertion sym -> IO ()
C.addProofObligation bak
bak (Assertion (ExprBuilder t st fs) -> IO ())
-> Assertion (ExprBuilder t st fs) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pred (ExprBuilder t st fs)
-> SimError -> Assertion (ExprBuilder t st fs)
forall pred msg. pred -> msg -> LabeledPred pred msg
C.LabeledPred Expr t BaseBoolType
Pred (ExprBuilder t st fs)
header_inv (SimError -> Assertion (ExprBuilder t st fs))
-> SimError -> Assertion (ExprBuilder t st fs)
forall a b. (a -> b) -> a -> b
$ ProgramLoc -> SimErrorReason -> SimError
C.SimError ProgramLoc
loc SimErrorReason
""

                Expr t BaseBoolType
inv <- sym
-> SymFn sym x BaseBoolType
-> Assignment (SymExpr sym) x
-> IO (Pred sym)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
IsSymExprBuilder sym =>
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
W4.applySymFn sym
sym SymFn sym x BaseBoolType
ExprSymFn t x BaseBoolType
inv_pred Assignment (Expr t) x
Assignment (SymExpr sym) x
uninterpreted_constants
                bak -> Assumption (ExprBuilder t st fs) -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assumption sym -> IO ()
C.addAssumption bak
bak (Assumption (ExprBuilder t st fs) -> IO ())
-> Assumption (ExprBuilder t st fs) -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramLoc
-> String -> Expr t BaseBoolType -> CrucibleAssumption (Expr t)
forall (e :: BaseType -> Type).
ProgramLoc -> String -> e BaseBoolType -> CrucibleAssumption e
C.GenericAssumption ProgramLoc
loc String
"inv" Expr t BaseBoolType
inv

                SomeSymFn sym -> IO (SomeSymFn sym)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SomeSymFn sym -> IO (SomeSymFn sym))
-> SomeSymFn sym -> IO (SomeSymFn sym)
forall a b. (a -> b) -> a -> b
$ SymFn (ExprBuilder t st fs) x BaseBoolType
-> SomeSymFn (ExprBuilder t st fs)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
SymFn sym args ret -> SomeSymFn sym
W4.SomeSymFn SymFn (ExprBuilder t st fs) x BaseBoolType
ExprSymFn t x BaseBoolType
inv_pred

            IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ SomeSymFn sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall sym (wptr :: Nat) ext.
SomeSymFn sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddInvPred SomeSymFn sym
some_inv_pred

            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"proof_goals_and_assumptions_vars: "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Doc Any] -> String
forall a. Show a => a -> String
show ((Some (Expr t) -> Doc Any) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map ((forall (tp :: BaseType). Expr t tp -> Doc Any)
-> Some (Expr t) -> Doc Any
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome Expr t tp -> Doc Any
forall (tp :: BaseType). Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr) ([Some (Expr t)] -> [Doc Any]) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t)) -> [Some (Expr t)]
forall a. Set a -> [a]
Set.toList Set (Some (Expr t))
proof_goals_and_assumptions_vars)
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"body_values_vars: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Doc Any] -> String
forall a. Show a => a -> String
show ((Some (Expr t) -> Doc Any) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map ((forall (tp :: BaseType). Expr t tp -> Doc Any)
-> Some (Expr t) -> Doc Any
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome Expr t tp -> Doc Any
forall (tp :: BaseType). Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr) ([Some (Expr t)] -> [Doc Any]) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t)) -> [Some (Expr t)]
forall a. Set a -> [a]
Set.toList Set (Some (Expr t))
body_values_vars)
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"header_values_vars: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Doc Any] -> String
forall a. Show a => a -> String
show ((Some (Expr t) -> Doc Any) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map ((forall (tp :: BaseType). Expr t tp -> Doc Any)
-> Some (Expr t) -> Doc Any
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome Expr t tp -> Doc Any
forall (tp :: BaseType). Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr) ([Some (Expr t)] -> [Doc Any]) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t)) -> [Some (Expr t)]
forall a. Set a -> [a]
Set.toList Set (Some (Expr t))
header_values_vars)
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"uninterpreted_constants: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Doc Any] -> String
forall a. Show a => a -> String
show ((Some (Expr t) -> Doc Any) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map ((forall (tp :: BaseType). Expr t tp -> Doc Any)
-> Some (Expr t) -> Doc Any
forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome Expr t tp -> Doc Any
forall (tp :: BaseType). Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr) ([Some (Expr t)] -> [Doc Any]) -> [Some (Expr t)] -> [Doc Any]
forall a b. (a -> b) -> a -> b
$ Set (Some (Expr t)) -> [Some (Expr t)]
forall a. Set a -> [a]
Set.toList Set (Some (Expr t))
filtered_vars)

            IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id (FixpointState sym wptr blocks args
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
              FixpointRecord sym wptr blocks args
-> SomeSymFn sym
-> Some (Assignment (SymExpr sym))
-> Pred sym
-> FixpointState sym wptr blocks args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> SomeSymFn sym
-> Some (Assignment (SymExpr sym))
-> Pred sym
-> FixpointState sym wptr blocks args
CheckFixpoint
                FixpointRecord
                { fixpointBlockId :: BlockID blocks args
fixpointBlockId = BlockID blocks args
block_id
                , fixpointAssumptionFrameIdentifier :: FrameIdentifier
fixpointAssumptionFrameIdentifier = FrameIdentifier
assumption_frame_identifier
                , fixpointSubstitution :: MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution = MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
normal_substitution
                , fixpointRegMap :: RegMap sym args
fixpointRegMap = FixpointRecord sym wptr blocks args -> RegMap sym args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> RegMap sym args
fixpointRegMap FixpointRecord sym wptr blocks args
fixpoint_record
                , fixpointMemSubstitution :: Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution = Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution
                , fixpointEqualitySubstitution :: MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution = MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
equality_substitution
                , fixpointIndex :: SymBV sym wptr
fixpointIndex = FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record
                }
                SomeSymFn sym
some_inv_pred
                -- implicit_vars
                Some (Assignment (Expr t))
Some (Assignment (SymExpr sym))
some_uninterpreted_constants
                Expr t BaseBoolType
Pred sym
loop_condition

            ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecutionFeatureResult p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp.
ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureModifiedState (ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp)
-> ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall a b. (a -> b) -> a -> b
$ RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (args :: Ctx CrucibleType).
RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
C.RunningState (BlockID blocks args -> RunningStateInfo blocks args
forall (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
BlockID blocks args -> RunningStateInfo blocks args
C.RunBlockStart BlockID blocks args
block_id) (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> ExecState p sym ext rtp)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall a b. (a -> b) -> a -> b
$
              SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& ((CallFrame sym ext blocks r args
 -> Identity (CallFrame sym ext blocks r args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame ((CallFrame sym ext blocks r args
  -> Identity (CallFrame sym ext blocks r args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((RegMap sym args -> Identity (RegMap sym args))
    -> CallFrame sym ext blocks r args
    -> Identity (CallFrame sym ext blocks r args))
-> (RegMap sym args -> Identity (RegMap sym args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegMap sym args -> Identity (RegMap sym args))
-> CallFrame sym ext blocks r args
-> Identity (CallFrame sym ext blocks r args)
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (f :: Type -> Type).
Functor f =>
(RegMap sym args -> f (RegMap sym args))
-> CallFrame sym ext blocks ret args
-> f (CallFrame sym ext blocks ret args)
C.frameRegs) ((RegMap sym args -> Identity (RegMap sym args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> RegMap sym args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Assignment (RegEntry sym) args -> RegMap sym args
forall sym (ctx :: Ctx CrucibleType).
Assignment (RegEntry sym) ctx -> RegMap sym ctx
C.RegMap Assignment (RegEntry sym) args
res_reg_map
                SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& (SymGlobalState sym -> Identity (SymGlobalState sym))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals ((SymGlobalState sym -> Identity (SymGlobalState sym))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> (SymGlobalState sym -> SymGlobalState sym)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ GlobalVar Mem
-> RegValue sym Mem -> SymGlobalState sym -> SymGlobalState sym
forall (tp :: CrucibleType) sym.
GlobalVar tp
-> RegValue sym tp -> SymGlobalState sym -> SymGlobalState sym
C.insertGlobal GlobalVar Mem
mem_var RegValue sym Mem
MemImpl sym
res_mem_impl

          else do
            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"SimpleLoopFixpoint: RunningState: ComputeFixpoint: -> ComputeFixpoint"

            -- write any new widening variables into memory state
            MemImpl sym
res_mem_impl <- bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
storeMemJoinVariables bak
bak
              (MemImpl sym
header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) })
              Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution
              MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty

            IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id (FixpointState sym wptr blocks args
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
ComputeFixpoint
              FixpointRecord
              { fixpointBlockId :: BlockID blocks args
fixpointBlockId = BlockID blocks args
block_id
              , fixpointAssumptionFrameIdentifier :: FrameIdentifier
fixpointAssumptionFrameIdentifier = FrameIdentifier
assumption_frame_identifier
              , fixpointSubstitution :: MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution = MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
join_substitution
              , fixpointRegMap :: RegMap sym args
fixpointRegMap = Assignment (RegEntry sym) args -> RegMap sym args
forall sym (ctx :: Ctx CrucibleType).
Assignment (RegEntry sym) ctx -> RegMap sym ctx
C.RegMap Assignment (RegEntry sym) args
join_reg_map
              , fixpointMemSubstitution :: Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution = Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
mem_substitution
              , fixpointEqualitySubstitution :: MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution = MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty
              , fixpointIndex :: SymBV sym wptr
fixpointIndex = FixpointRecord sym wptr blocks args -> SymBV sym wptr
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> SymBV sym wptr
fixpointIndex FixpointRecord sym wptr blocks args
fixpoint_record
              }
            ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecutionFeatureResult p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp.
ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureModifiedState (ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp)
-> ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall a b. (a -> b) -> a -> b
$ RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (args :: Ctx CrucibleType).
RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
C.RunningState (BlockID blocks args -> RunningStateInfo blocks args
forall (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
BlockID blocks args -> RunningStateInfo blocks args
C.RunBlockStart BlockID blocks args
block_id) (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> ExecState p sym ext rtp)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall a b. (a -> b) -> a -> b
$
              SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& ((CallFrame sym ext blocks r args
 -> Identity (CallFrame sym ext blocks r args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame ((CallFrame sym ext blocks r args
  -> Identity (CallFrame sym ext blocks r args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((RegMap sym args -> Identity (RegMap sym args))
    -> CallFrame sym ext blocks r args
    -> Identity (CallFrame sym ext blocks r args))
-> (RegMap sym args -> Identity (RegMap sym args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegMap sym args -> Identity (RegMap sym args))
-> CallFrame sym ext blocks r args
-> Identity (CallFrame sym ext blocks r args)
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (f :: Type -> Type).
Functor f =>
(RegMap sym args -> f (RegMap sym args))
-> CallFrame sym ext blocks ret args
-> f (CallFrame sym ext blocks ret args)
C.frameRegs) ((RegMap sym args -> Identity (RegMap sym args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> RegMap sym args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Assignment (RegEntry sym) args -> RegMap sym args
forall sym (ctx :: Ctx CrucibleType).
Assignment (RegEntry sym) ctx -> RegMap sym ctx
C.RegMap Assignment (RegEntry sym) args
join_reg_map
                SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& (SymGlobalState sym -> Identity (SymGlobalState sym))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals ((SymGlobalState sym -> Identity (SymGlobalState sym))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> (SymGlobalState sym -> SymGlobalState sym)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ GlobalVar Mem
-> RegValue sym Mem -> SymGlobalState sym -> SymGlobalState sym
forall (tp :: CrucibleType) sym.
GlobalVar tp
-> RegValue sym tp -> SymGlobalState sym -> SymGlobalState sym
C.insertGlobal GlobalVar Mem
mem_var RegValue sym Mem
MemImpl sym
res_mem_impl

    CheckFixpoint FixpointRecord sym wptr blocks args
fixpoint_record SomeSymFn sym
some_inv_pred Some (Assignment (SymExpr sym))
some_uninterpreted_constants Pred sym
loop_condition -> do
        ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"SimpleLoopFixpoint: RunningState: "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"CheckFixpoint"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"AfterFixpoint"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks args -> String
forall a. Show a => a -> String
show BlockID blocks args
block_id

        ProgramLoc
loc <- sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
W4.getCurrentProgramLoc sym
sym

        -- assert that the hypothesis we made about the loop termination condition is true
        (()
_ :: ()) <- case (SomeSymFn sym
some_inv_pred, Some (Assignment (Expr t))
Some (Assignment (SymExpr sym))
some_uninterpreted_constants) of
          (W4.SomeSymFn SymFn sym args ret
inv_pred, Some Assignment (Expr t) x
uninterpreted_constants)
            | Just args :~: x
Refl <- Assignment BaseTypeRepr args
-> Assignment BaseTypeRepr x -> Maybe (args :~: x)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Ctx BaseType) (b :: Ctx BaseType).
Assignment BaseTypeRepr a
-> Assignment BaseTypeRepr b -> Maybe (a :~: b)
testEquality (ExprSymFn t args ret -> Assignment BaseTypeRepr args
forall (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Assignment BaseTypeRepr args
forall (fn :: Ctx BaseType -> BaseType -> Type)
       (args :: Ctx BaseType) (ret :: BaseType).
IsSymFn fn =>
fn args ret -> Assignment BaseTypeRepr args
W4.fnArgTypes SymFn sym args ret
ExprSymFn t args ret
inv_pred) ((forall (x :: BaseType). Expr t x -> BaseTypeRepr x)
-> forall (x :: Ctx BaseType).
   Assignment (Expr t) x -> Assignment BaseTypeRepr x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> forall (x :: Ctx BaseType). Assignment f x -> Assignment g x
fmapFC Expr t x -> BaseTypeRepr x
forall (x :: BaseType). Expr t x -> BaseTypeRepr x
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType Assignment (Expr t) x
uninterpreted_constants)
            , Just ret :~: BaseBoolType
Refl <- BaseTypeRepr ret
-> BaseTypeRepr BaseBoolType -> Maybe (ret :~: BaseBoolType)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
BaseTypeRepr a -> BaseTypeRepr b -> Maybe (a :~: b)
testEquality (ExprSymFn t args ret -> BaseTypeRepr ret
forall (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> BaseTypeRepr ret
forall (fn :: Ctx BaseType -> BaseType -> Type)
       (args :: Ctx BaseType) (ret :: BaseType).
IsSymFn fn =>
fn args ret -> BaseTypeRepr ret
W4.fnReturnType SymFn sym args ret
ExprSymFn t args ret
inv_pred) BaseTypeRepr BaseBoolType
W4.BaseBoolRepr -> do
              Expr t BaseBoolType
inv <- sym
-> SymFn sym args BaseBoolType
-> Assignment (SymExpr sym) args
-> IO (Pred sym)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
IsSymExprBuilder sym =>
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
W4.applySymFn sym
sym SymFn sym args ret
SymFn sym args BaseBoolType
inv_pred (Assignment (SymExpr sym) args -> IO (Pred sym))
-> Assignment (SymExpr sym) args -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (Expr t)
-> Assignment (Expr t) args -> Assignment (Expr t) args
forall {k} {l} (k :: k -> Type) (f :: (k -> Type) -> l -> Type)
       (l :: l).
(OrdF k, FunctorFC f) =>
MapF k k -> f k l -> f k l
applySubstitutionFC
                ((forall (x :: BaseType). FixpointEntry sym x -> Expr t x)
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall {k} (m :: (k -> Type) -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorF m =>
(forall (x :: k). f x -> g x) -> m f -> m g
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> MapF (Expr t) f -> MapF (Expr t) g
fmapF FixpointEntry sym x -> Expr t x
FixpointEntry (ExprBuilder t st fs) x
-> SymExpr (ExprBuilder t st fs) x
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
forall (x :: BaseType). FixpointEntry sym x -> Expr t x
bodyValue (MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t))
-> MapF (Expr t) (FixpointEntry sym) -> MapF (Expr t) (Expr t)
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution FixpointRecord sym wptr blocks args
fixpoint_record)
                Assignment (Expr t) args
Assignment (Expr t) x
uninterpreted_constants
              bak -> Assertion (ExprBuilder t st fs) -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assertion sym -> IO ()
C.addProofObligation bak
bak (Assertion (ExprBuilder t st fs) -> IO ())
-> Assertion (ExprBuilder t st fs) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pred (ExprBuilder t st fs)
-> SimError -> Assertion (ExprBuilder t st fs)
forall pred msg. pred -> msg -> LabeledPred pred msg
C.LabeledPred Expr t BaseBoolType
Pred (ExprBuilder t st fs)
inv (SimError -> Assertion (ExprBuilder t st fs))
-> SimError -> Assertion (ExprBuilder t st fs)
forall a b. (a -> b) -> a -> b
$ ProgramLoc -> SimErrorReason -> SimError
C.SimError ProgramLoc
loc SimErrorReason
""
            | Bool
otherwise -> String -> [String] -> IO ()
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.simpleLoopFixpoint" [String
"type mismatch: CheckFixpoint"]

        CrucibleAssumptions (SymExpr (ExprBuilder t st fs))
frame_assumptions <- bak
-> FrameIdentifier
-> IO (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)))
forall sym bak.
IsSymBackend sym bak =>
bak -> FrameIdentifier -> IO (Assumptions sym)
C.popAssumptionFrame bak
bak (FrameIdentifier
 -> IO (CrucibleAssumptions (SymExpr (ExprBuilder t st fs))))
-> FrameIdentifier
-> IO (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)))
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args -> FrameIdentifier
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> FrameIdentifier
fixpointAssumptionFrameIdentifier FixpointRecord sym wptr blocks args
fixpoint_record

        -- body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ fixpointMemSubstitution fixpoint_record
        -- let res_substitution = MapF.mapWithKey
        --       (\variable fixpoint_entry ->
        --         fixpoint_entry
        --           { bodyValue = MapF.findWithDefault (bodyValue fixpoint_entry) variable body_mem_substitution
        --           })
        --       (fixpointSubstitution fixpoint_record)
        -- ?logMessage $ "res_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList res_substitution)

        -- match things up with the input function that describes the loop body behavior
        MapF (Expr t) (Expr t)
fixpoint_substitution <- case Maybe
  (MapF (SymExpr sym) (FixpointEntry sym)
   -> Pred sym
   -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
maybe_fixpoint_func of
          Just MapF (SymExpr sym) (FixpointEntry sym)
-> Pred sym
-> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym))
fixpoint_func -> do
            -- (fixpoint_func_substitution, maybe_fixpoint_func_condition) <- fixpoint_func res_substitution loop_condition

            MapF (Expr t) (FixpointEntry sym)
correct_substitution <- (forall (s :: BaseType).
 FixpointEntry sym s -> IO (FixpointEntry sym s))
-> MapF (Expr t) (FixpointEntry sym)
-> IO (MapF (Expr t) (FixpointEntry sym))
forall {k} (t :: (k -> Type) -> Type) (m :: Type -> Type)
       (e :: k -> Type) (f :: k -> Type).
(TraversableF t, Applicative m) =>
(forall (s :: k). e s -> m (f s)) -> t e -> m (t f)
forall (m :: Type -> Type) (e :: BaseType -> Type)
       (f :: BaseType -> Type).
Applicative m =>
(forall (s :: BaseType). e s -> m (f s))
-> MapF (Expr t) e -> m (MapF (Expr t) f)
traverseF
              (\FixpointEntry sym s
fixpoint_entry -> do
                Expr t s
correct_body_value <- sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym s
-> IO (SymExpr sym s)
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
W4.substituteBoundVars sym
sym (sym
-> MapF (SymExpr sym) (SymExpr sym)
-> MapF (BoundVar sym) (SymExpr sym)
forall sym (a :: BaseType -> Type).
IsSymExprBuilder sym =>
sym -> MapF (SymExpr sym) a -> MapF (BoundVar sym) a
asBoundVarSubstitution sym
sym (MapF (SymExpr sym) (SymExpr sym)
 -> MapF (BoundVar sym) (SymExpr sym))
-> MapF (SymExpr sym) (SymExpr sym)
-> MapF (BoundVar sym) (SymExpr sym)
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (SymExpr sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution FixpointRecord sym wptr blocks args
fixpoint_record) (SymExpr sym s -> IO (SymExpr sym s))
-> SymExpr sym s -> IO (SymExpr sym s)
forall a b. (a -> b) -> a -> b
$ FixpointEntry (ExprBuilder t st fs) s
-> SymExpr (ExprBuilder t st fs) s
forall sym (tp :: BaseType). FixpointEntry sym tp -> SymExpr sym tp
bodyValue FixpointEntry sym s
FixpointEntry (ExprBuilder t st fs) s
fixpoint_entry
                FixpointEntry sym s -> IO (FixpointEntry sym s)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FixpointEntry sym s -> IO (FixpointEntry sym s))
-> FixpointEntry sym s -> IO (FixpointEntry sym s)
forall a b. (a -> b) -> a -> b
$ FixpointEntry sym s
fixpoint_entry
                  { bodyValue = correct_body_value
                  })
              (FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (FixpointEntry sym)
fixpointSubstitution FixpointRecord sym wptr blocks args
fixpoint_record)
            (MapF (Expr t) (Expr t)
fixpoint_func_substitution, Maybe (Expr t BaseBoolType)
maybe_fixpoint_func_condition) <- MapF (SymExpr sym) (FixpointEntry sym)
-> Pred sym
-> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym))
fixpoint_func MapF (Expr t) (FixpointEntry sym)
MapF (SymExpr sym) (FixpointEntry sym)
correct_substitution Pred sym
loop_condition
            -- (fixpoint_func_substitution, maybe_fixpoint_func_condition) <- fixpoint_func (fixpointSubstitution fixpoint_record) loop_condition

            ()
_ <- case Maybe (Expr t BaseBoolType)
maybe_fixpoint_func_condition of
              Just Expr t BaseBoolType
fixpoint_func_condition -> do
                Expr t BaseBoolType
bak_assumptions <- IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType))
-> IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> Assumptions sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Assumptions sym -> IO (Pred sym)
C.assumptionsPred sym
sym (CrucibleAssumptions (Expr t) -> IO (Expr t BaseBoolType))
-> IO (CrucibleAssumptions (Expr t)) -> IO (Expr t BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< bak -> IO (CrucibleAssumptions (SymExpr (ExprBuilder t st fs)))
forall sym bak. IsSymBackend sym bak => bak -> IO (Assumptions sym)
C.collectAssumptions bak
bak
                Expr t BaseBoolType
inv_assumption <- CrucibleAssumption (Expr t) -> Expr t BaseBoolType
forall (e :: BaseType -> Type).
CrucibleAssumption e -> e BaseBoolType
C.assumptionPred (CrucibleAssumption (Expr t) -> Expr t BaseBoolType)
-> IO (CrucibleAssumption (Expr t)) -> IO (Expr t BaseBoolType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> sym -> Assumptions sym -> IO (CrucibleAssumption (SymExpr sym))
forall sym.
sym -> Assumptions sym -> IO (CrucibleAssumption (SymExpr sym))
headAssumption sym
sym Assumptions sym
CrucibleAssumptions (SymExpr (ExprBuilder t st fs))
frame_assumptions
                Expr t BaseBoolType
all_assumptions <- IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType))
-> IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
W4.andPred sym
sym Expr t BaseBoolType
Pred sym
bak_assumptions Expr t BaseBoolType
Pred sym
inv_assumption
                Expr t BaseBoolType
implication <- IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType))
-> IO (Expr t BaseBoolType) -> IO (Expr t BaseBoolType)
forall a b. (a -> b) -> a -> b
$ sym -> Pred sym -> Pred sym -> IO (Pred sym)
forall sym.
IsExprBuilder sym =>
sym -> Pred sym -> Pred sym -> IO (Pred sym)
W4.impliesPred sym
sym Expr t BaseBoolType
Pred sym
all_assumptions Expr t BaseBoolType
Pred sym
fixpoint_func_condition
                IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ Pred sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall sym (wptr :: Nat) ext.
Pred sym
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
executionFeatureContextAddLoopFunEquivCond Expr t BaseBoolType
Pred sym
implication
                -- tmp_frame_id <- C.pushAssumptionFrame bak
                -- C.addProofObligation bak $ C.LabeledPred fixpoint_func_condition $ C.SimError loc ""
                -- (_, obligations) <- C.popAssumptionFrameAndObligations bak tmp_frame_id
                -- ?logMessage "before convertProofObligationsAsImplications"
                -- implications <- C.convertProofObligationsAsImplications sym obligations
                -- ?logMessage "after convertProofObligationsAsImplications"
                -- forM_ implications $ \implication ->
                --   modifyIORef' fixpoint_state_ref $ executionFeatureContextAddLoopFunEquivCond implication
              Maybe (Expr t BaseBoolType)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

            ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"fixpoint_func_substitution: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Doc Any, Doc Any)] -> String
forall a. Show a => a -> String
show ((Pair (Expr t) (Expr t) -> (Doc Any, Doc Any))
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MapF.Pair Expr t tp
x Expr t tp
y) -> (Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
x, Expr t tp -> Doc Any
forall (tp :: BaseType) ann. Expr t tp -> Doc ann
forall (e :: BaseType -> Type) (tp :: BaseType) ann.
IsExpr e =>
e tp -> Doc ann
W4.printSymExpr Expr t tp
y)) ([Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)])
-> [Pair (Expr t) (Expr t)] -> [(Doc Any, Doc Any)]
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (Expr t) -> [Pair (Expr t) (Expr t)]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList MapF (Expr t) (Expr t)
fixpoint_func_substitution)

            MapF (Expr t) (Expr t) -> IO (MapF (Expr t) (Expr t))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MapF (Expr t) (Expr t)
fixpoint_func_substitution

          Maybe
  (MapF (SymExpr sym) (FixpointEntry sym)
   -> Pred sym
   -> IO (MapF (SymExpr sym) (SymExpr sym), Maybe (Pred sym)))
Nothing -> MapF (Expr t) (Expr t) -> IO (MapF (Expr t) (Expr t))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MapF (Expr t) (Expr t)
forall {v} (k :: v -> Type) (a :: v -> Type). MapF k a
MapF.empty

        let body_mem_impl :: MemImpl sym
body_mem_impl = Maybe (MemImpl sym) -> MemImpl sym
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (MemImpl sym) -> MemImpl sym)
-> Maybe (MemImpl sym) -> MemImpl sym
forall a b. (a -> b) -> a -> b
$ GlobalVar Mem -> SymGlobalState sym -> Maybe (RegValue sym Mem)
forall (tp :: CrucibleType) sym.
GlobalVar tp -> SymGlobalState sym -> Maybe (RegValue sym tp)
C.lookupGlobal GlobalVar Mem
mem_var (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (SymGlobalState sym)
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (SymGlobalState sym)
-> SymGlobalState sym
forall s a. s -> Getting a s a -> a
^. Getting
  (SymGlobalState sym)
  (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
  (SymGlobalState sym)
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals)
        let (MemImpl sym
header_mem_impl, MemAllocs sym
_mem_allocs, MemWrites sym
_mem_writes) = MemImpl sym -> (MemImpl sym, MemAllocs sym, MemWrites sym)
forall sym.
IsSymInterface sym =>
MemImpl sym -> (MemImpl sym, MemAllocs sym, MemWrites sym)
dropMemStackFrame MemImpl sym
body_mem_impl

        MapF (Expr t) (Expr t)
fixpoint_equality_substitution <- (forall (s :: BaseType). Expr t s -> IO (Expr t s))
-> MapF (Expr t) (Expr t) -> IO (MapF (Expr t) (Expr t))
forall {k} (t :: (k -> Type) -> Type) (m :: Type -> Type)
       (e :: k -> Type) (f :: k -> Type).
(TraversableF t, Applicative m) =>
(forall (s :: k). e s -> m (f s)) -> t e -> m (t f)
forall (m :: Type -> Type) (e :: BaseType -> Type)
       (f :: BaseType -> Type).
Applicative m =>
(forall (s :: BaseType). e s -> m (f s))
-> MapF (Expr t) e -> m (MapF (Expr t) f)
traverseF
          (sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym s
-> IO (SymExpr sym s)
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
forall (tp :: BaseType).
sym
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym tp
-> IO (SymExpr sym tp)
W4.substituteBoundVars sym
sym (MapF (BoundVar sym) (SymExpr sym)
 -> SymExpr sym s -> IO (SymExpr sym s))
-> MapF (BoundVar sym) (SymExpr sym)
-> SymExpr sym s
-> IO (SymExpr sym s)
forall a b. (a -> b) -> a -> b
$ sym -> MapF (SymExpr sym) (Expr t) -> MapF (BoundVar sym) (Expr t)
forall sym (a :: BaseType -> Type).
IsSymExprBuilder sym =>
sym -> MapF (SymExpr sym) a -> MapF (BoundVar sym) a
asBoundVarSubstitution sym
sym MapF (Expr t) (Expr t)
MapF (SymExpr sym) (Expr t)
fixpoint_substitution) (MapF (Expr t) (Expr t) -> IO (MapF (Expr t) (Expr t)))
-> MapF (Expr t) (Expr t) -> IO (MapF (Expr t) (Expr t))
forall a b. (a -> b) -> a -> b
$
          FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (SymExpr sym)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> MapF (SymExpr sym) (SymExpr sym)
fixpointEqualitySubstitution FixpointRecord sym wptr blocks args
fixpoint_record
        let fixpoint_equality_substitution' :: MapF (Expr t) (Expr t)
fixpoint_equality_substitution' = MapF (Expr t) (Expr t)
-> MapF (Expr t) (Expr t) -> MapF (Expr t) (Expr t)
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
MapF k a -> MapF k a -> MapF k a
MapF.union MapF (Expr t) (Expr t)
fixpoint_substitution MapF (Expr t) (Expr t)
fixpoint_equality_substitution
        let res_reg_map :: RegMap sym args
res_reg_map = Assignment (RegEntry sym) args -> RegMap sym args
forall sym (ctx :: Ctx CrucibleType).
Assignment (RegEntry sym) ctx -> RegMap sym ctx
C.RegMap (Assignment (RegEntry sym) args -> RegMap sym args)
-> Assignment (RegEntry sym) args -> RegMap sym args
forall a b. (a -> b) -> a -> b
$ sym
-> MapF (SymExpr sym) (SymExpr sym)
-> Assignment (RegEntry sym) args
-> Assignment (RegEntry sym) args
forall sym (ctx :: Ctx CrucibleType).
IsSymInterface sym =>
sym
-> MapF (SymExpr sym) (SymExpr sym)
-> Assignment (RegEntry sym) ctx
-> Assignment (RegEntry sym) ctx
applySubstitutionRegEntries sym
sym MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
fixpoint_equality_substitution' (RegMap sym args -> Assignment (RegEntry sym) args
forall sym (ctx :: Ctx CrucibleType).
RegMap sym ctx -> Assignment (RegEntry sym) ctx
C.regMap (RegMap sym args -> Assignment (RegEntry sym) args)
-> RegMap sym args -> Assignment (RegEntry sym) args
forall a b. (a -> b) -> a -> b
$ FixpointRecord sym wptr blocks args -> RegMap sym args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args -> RegMap sym args
fixpointRegMap FixpointRecord sym wptr blocks args
fixpoint_record)
        MemImpl sym
res_mem_impl <- bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
forall sym bak (wptr :: Nat).
(IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym,
 ?memOpts::MemOptions) =>
bak
-> MemImpl sym
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
-> MapF (SymExpr sym) (SymExpr sym)
-> IO (MemImpl sym)
storeMemJoinVariables bak
bak MemImpl sym
header_mem_impl (FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)
fixpointMemSubstitution FixpointRecord sym wptr blocks args
fixpoint_record) MapF (Expr t) (Expr t)
MapF (SymExpr sym) (SymExpr sym)
fixpoint_equality_substitution'

        (()
_ :: ()) <- case (SomeSymFn sym
some_inv_pred, Some (Assignment (Expr t))
Some (Assignment (SymExpr sym))
some_uninterpreted_constants) of
          (W4.SomeSymFn SymFn sym args ret
inv_pred, Some Assignment (Expr t) x
uninterpreted_constants)
            | Just args :~: x
Refl <- Assignment BaseTypeRepr args
-> Assignment BaseTypeRepr x -> Maybe (args :~: x)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Ctx BaseType) (b :: Ctx BaseType).
Assignment BaseTypeRepr a
-> Assignment BaseTypeRepr b -> Maybe (a :~: b)
testEquality (ExprSymFn t args ret -> Assignment BaseTypeRepr args
forall (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Assignment BaseTypeRepr args
forall (fn :: Ctx BaseType -> BaseType -> Type)
       (args :: Ctx BaseType) (ret :: BaseType).
IsSymFn fn =>
fn args ret -> Assignment BaseTypeRepr args
W4.fnArgTypes SymFn sym args ret
ExprSymFn t args ret
inv_pred) ((forall (x :: BaseType). Expr t x -> BaseTypeRepr x)
-> forall (x :: Ctx BaseType).
   Assignment (Expr t) x -> Assignment BaseTypeRepr x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> forall (x :: Ctx BaseType). Assignment f x -> Assignment g x
fmapFC Expr t x -> BaseTypeRepr x
forall (x :: BaseType). Expr t x -> BaseTypeRepr x
forall (e :: BaseType -> Type) (tp :: BaseType).
IsExpr e =>
e tp -> BaseTypeRepr tp
W4.exprType Assignment (Expr t) x
uninterpreted_constants)
            , Just ret :~: BaseBoolType
Refl <- BaseTypeRepr ret
-> BaseTypeRepr BaseBoolType -> Maybe (ret :~: BaseBoolType)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
BaseTypeRepr a -> BaseTypeRepr b -> Maybe (a :~: b)
testEquality (ExprSymFn t args ret -> BaseTypeRepr ret
forall (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> BaseTypeRepr ret
forall (fn :: Ctx BaseType -> BaseType -> Type)
       (args :: Ctx BaseType) (ret :: BaseType).
IsSymFn fn =>
fn args ret -> BaseTypeRepr ret
W4.fnReturnType SymFn sym args ret
ExprSymFn t args ret
inv_pred) BaseTypeRepr BaseBoolType
W4.BaseBoolRepr -> do
              Expr t BaseBoolType
inv <- sym
-> SymFn sym args BaseBoolType
-> Assignment (SymExpr sym) args
-> IO (Pred sym)
forall sym (args :: Ctx BaseType) (ret :: BaseType).
IsSymExprBuilder sym =>
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
sym
-> SymFn sym args ret
-> Assignment (SymExpr sym) args
-> IO (SymExpr sym ret)
W4.applySymFn sym
sym SymFn sym args ret
SymFn sym args BaseBoolType
inv_pred (Assignment (SymExpr sym) args -> IO (Pred sym))
-> Assignment (SymExpr sym) args -> IO (Pred sym)
forall a b. (a -> b) -> a -> b
$ MapF (Expr t) (Expr t)
-> Assignment (Expr t) args -> Assignment (Expr t) args
forall {k} {l} (k :: k -> Type) (f :: (k -> Type) -> l -> Type)
       (l :: l).
(OrdF k, FunctorFC f) =>
MapF k k -> f k l -> f k l
applySubstitutionFC MapF (Expr t) (Expr t)
fixpoint_substitution Assignment (Expr t) args
Assignment (Expr t) x
uninterpreted_constants
              bak -> Assumption (ExprBuilder t st fs) -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assumption sym -> IO ()
C.addAssumption bak
bak (Assumption (ExprBuilder t st fs) -> IO ())
-> Assumption (ExprBuilder t st fs) -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramLoc
-> String -> Expr t BaseBoolType -> CrucibleAssumption (Expr t)
forall (e :: BaseType -> Type).
ProgramLoc -> String -> e BaseBoolType -> CrucibleAssumption e
C.GenericAssumption ProgramLoc
loc String
"" Expr t BaseBoolType
inv
            | Bool
otherwise -> String -> [String] -> IO ()
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.simpleLoopFixpoint" [String
"type mismatch: CheckFixpoint"]

        IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id (FixpointState sym wptr blocks args
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
          FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> FixpointState sym wptr blocks args
AfterFixpoint
            -- fixpoint_record{ fixpointSubstitution = res_substitution }
            FixpointRecord sym wptr blocks args
fixpoint_record

        ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ExecutionFeatureResult p sym ext rtp
 -> IO (ExecutionFeatureResult p sym ext rtp))
-> ExecutionFeatureResult p sym ext rtp
-> IO (ExecutionFeatureResult p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp.
ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureModifiedState (ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp)
-> ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall a b. (a -> b) -> a -> b
$ RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (args :: Ctx CrucibleType).
RunningStateInfo blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
C.RunningState (BlockID blocks args -> RunningStateInfo blocks args
forall (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
BlockID blocks args -> RunningStateInfo blocks args
C.RunBlockStart BlockID blocks args
block_id) (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> ExecState p sym ext rtp)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> ExecState p sym ext rtp
forall a b. (a -> b) -> a -> b
$
          SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& ((CallFrame sym ext blocks r args
 -> Identity (CallFrame sym ext blocks r args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp (blocks :: Ctx (Ctx CrucibleType))
       (r :: CrucibleType) (a :: Ctx CrucibleType)
       (a' :: Ctx CrucibleType) (f :: Type -> Type).
Functor f =>
(CallFrame sym ext blocks r a -> f (CallFrame sym ext blocks r a'))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just a)
-> f (SimState p sym ext rtp (CrucibleLang blocks r) ('Just a'))
C.stateCrucibleFrame ((CallFrame sym ext blocks r args
  -> Identity (CallFrame sym ext blocks r args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((RegMap sym args -> Identity (RegMap sym args))
    -> CallFrame sym ext blocks r args
    -> Identity (CallFrame sym ext blocks r args))
-> (RegMap sym args -> Identity (RegMap sym args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegMap sym args -> Identity (RegMap sym args))
-> CallFrame sym ext blocks r args
-> Identity (CallFrame sym ext blocks r args)
forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (args :: Ctx CrucibleType)
       (f :: Type -> Type).
Functor f =>
(RegMap sym args -> f (RegMap sym args))
-> CallFrame sym ext blocks ret args
-> f (CallFrame sym ext blocks ret args)
C.frameRegs) ((RegMap sym args -> Identity (RegMap sym args))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> RegMap sym args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RegMap sym args
res_reg_map
            SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall a b. a -> (a -> b) -> b
& (SymGlobalState sym -> Identity (SymGlobalState sym))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Identity
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext q f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(SymGlobalState sym -> f2 (SymGlobalState sym))
-> SimState p sym ext q f1 args
-> f2 (SimState p sym ext q f1 args)
C.stateGlobals ((SymGlobalState sym -> Identity (SymGlobalState sym))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Identity
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> (SymGlobalState sym -> SymGlobalState sym)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ GlobalVar Mem
-> RegValue sym Mem -> SymGlobalState sym -> SymGlobalState sym
forall (tp :: CrucibleType) sym.
GlobalVar tp
-> RegValue sym tp -> SymGlobalState sym -> SymGlobalState sym
C.insertGlobal GlobalVar Mem
mem_var RegValue sym Mem
MemImpl sym
res_mem_impl

    AfterFixpoint{} -> do
      ?logMessage::String -> IO ()
String -> IO ()
?logMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SimpleLoopFixpoint: RunningState: AfterFixpoint -> ComputeFixpoint"
      bak
-> GlobalVar Mem
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
forall sym bak (wptr :: Nat) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType) p ext rtp (r :: CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, KnownNat wptr,
 HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> GlobalVar Mem
-> CallFrameHandle init ret blocks
-> BlockID blocks args
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
initializeFixpointState bak
bak GlobalVar Mem
mem_var CallFrameHandle init ret blocks
call_frame_handle BlockID blocks args
block_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref


handleSymbolicBranch ::
  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) =>
  bak ->
  CallFrameHandle init ret blocks ->
  C.BlockID blocks tp ->
  W4.Pred sym ->
  C.PausedFrame p sym ext rtp (C.CrucibleLang blocks r) ->
  C.PausedFrame p sym ext rtp (C.CrucibleLang blocks r) ->
  Maybe (C.Some (C.BlockID blocks)) ->
  Maybe (C.Some (C.BlockID blocks)) ->
  C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) ->
  IORef (ExecutionFeatureContext sym wptr ext) ->
  IO (C.ExecutionFeatureResult p sym ext rtp)
handleSymbolicBranch :: forall sym bak (wptr :: Nat) (init :: Ctx CrucibleType)
       (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (tp :: Ctx CrucibleType) p ext rtp (r :: CrucibleType)
       (args :: Ctx CrucibleType).
(IsSymBackend sym bak, HasPtrWidth wptr, KnownNat wptr,
 HasLLVMAnn sym, ?memOpts::MemOptions,
 ?logMessage::String -> IO ()) =>
bak
-> CallFrameHandle init ret blocks
-> BlockID blocks tp
-> Pred sym
-> PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> Maybe (Some (BlockID blocks))
-> Maybe (Some (BlockID blocks))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureResult p sym ext rtp)
handleSymbolicBranch bak
bak CallFrameHandle init ret blocks
call_frame_handle BlockID blocks tp
loop_block_id Pred sym
branch_condition PausedFrame p sym ext rtp (CrucibleLang blocks r)
true_frame PausedFrame p sym ext rtp (CrucibleLang blocks r)
false_frame Maybe (Some (BlockID blocks))
true_frame_parent_loop_id Maybe (Some (BlockID blocks))
false_frame_parent_loop_id SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref = do
  let sym :: sym
sym = bak -> sym
forall sym bak. HasSymInterface sym bak => bak -> sym
C.backendGetSym bak
bak

  (Pred sym
loop_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
inside_loop_frame, PausedFrame p sym ext rtp (CrucibleLang blocks r)
outside_loop_frame) <-
    if Maybe (Some (BlockID blocks))
true_frame_parent_loop_id Maybe (Some (BlockID blocks))
-> Maybe (Some (BlockID blocks)) -> Bool
forall a. Eq a => a -> a -> Bool
== Some (BlockID blocks) -> Maybe (Some (BlockID blocks))
forall a. a -> Maybe a
Just (BlockID blocks tp -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID blocks tp
loop_block_id)
    then
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
 PausedFrame p sym ext rtp (CrucibleLang blocks r))
-> IO
     (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
      PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym
branch_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
true_frame, PausedFrame p sym ext rtp (CrucibleLang blocks r)
false_frame)
    else if Maybe (Some (BlockID blocks))
false_frame_parent_loop_id Maybe (Some (BlockID blocks))
-> Maybe (Some (BlockID blocks)) -> Bool
forall a. Eq a => a -> a -> Bool
== Some (BlockID blocks) -> Maybe (Some (BlockID blocks))
forall a. a -> Maybe a
Just (BlockID blocks tp -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID blocks tp
loop_block_id)
    then do
      Pred sym
not_branch_condition <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
W4.notPred sym
sym Pred sym
branch_condition
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
 PausedFrame p sym ext rtp (CrucibleLang blocks r))
-> IO
     (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
      PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym
not_branch_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
false_frame, PausedFrame p sym ext rtp (CrucibleLang blocks r)
true_frame)
    else
      String
-> IO
     (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
      PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
 -> IO
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
       PausedFrame p sym ext rtp (CrucibleLang blocks r)))
-> String
-> IO
     (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r),
      PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a b. (a -> b) -> a -> b
$ String
"unsupported loop: loop header block id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockID blocks tp -> String
forall a. Show a => a -> String
show BlockID blocks tp
loop_block_id String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" true frame parent loop id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe (Some (BlockID blocks)) -> String
forall a. Show a => a -> String
show Maybe (Some (BlockID blocks))
true_frame_parent_loop_id String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" false frame parent loop id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe (Some (BlockID blocks)) -> String
forall a. Show a => a -> String
show Maybe (Some (BlockID blocks))
false_frame_parent_loop_id

  Just FixpointState sym wptr blocks tp
fixpoint_state <- CallFrameHandle init ret blocks
-> BlockID blocks tp
-> ExecutionFeatureContext sym wptr ext
-> Maybe (FixpointState sym wptr blocks tp)
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> ExecutionFeatureContext sym wptr ext
-> Maybe (FixpointState sym wptr blocks args)
callFrameContextLookup' CallFrameHandle init ret blocks
call_frame_handle BlockID blocks tp
loop_block_id (ExecutionFeatureContext sym wptr ext
 -> Maybe (FixpointState sym wptr blocks tp))
-> IO (ExecutionFeatureContext sym wptr ext)
-> IO (Maybe (FixpointState sym wptr blocks tp))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (ExecutionFeatureContext sym wptr ext)
-> IO (ExecutionFeatureContext sym wptr ext)
forall a. IORef a -> IO a
readIORef IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref
  (Pred sym
condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
frame) <- case FixpointState sym wptr blocks tp
fixpoint_state of
    FixpointState sym wptr blocks tp
BeforeFixpoint -> String
-> [String]
-> IO (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. HasCallStack => String -> [String] -> a
C.panic String
"SimpleLoopFixpoint.simpleLoopFixpoint:" [String
"BeforeFixpoint"]

    ComputeFixpoint{} -> do
      -- continue in the loop
      ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint: SymbolicBranchState: ComputeFixpoint"
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
-> IO (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym
loop_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
inside_loop_frame)

    CheckFixpoint FixpointRecord sym wptr blocks tp
fixpoint_record SomeSymFn sym
some_inv_pred Some (Assignment (SymExpr sym))
some_uninterpreted_constants Pred sym
_ -> do
      -- continue in the loop
      ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint: SymbolicBranchState: CheckFixpoint"
      IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> BlockID blocks tp
-> FixpointState sym wptr blocks tp
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) (args :: Ctx CrucibleType) sym
       (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> BlockID blocks args
-> FixpointState sym wptr blocks args
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextInsert CallFrameHandle init ret blocks
call_frame_handle BlockID blocks tp
loop_block_id (FixpointState sym wptr blocks tp
 -> ExecutionFeatureContext sym wptr ext
 -> ExecutionFeatureContext sym wptr ext)
-> FixpointState sym wptr blocks tp
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall a b. (a -> b) -> a -> b
$
        FixpointRecord sym wptr blocks tp
-> SomeSymFn sym
-> Some (Assignment (SymExpr sym))
-> Pred sym
-> FixpointState sym wptr blocks tp
forall sym (wptr :: Nat) (blocks :: Ctx (Ctx CrucibleType))
       (args :: Ctx CrucibleType).
FixpointRecord sym wptr blocks args
-> SomeSymFn sym
-> Some (Assignment (SymExpr sym))
-> Pred sym
-> FixpointState sym wptr blocks args
CheckFixpoint FixpointRecord sym wptr blocks tp
fixpoint_record SomeSymFn sym
some_inv_pred Some (Assignment (SymExpr sym))
some_uninterpreted_constants Pred sym
loop_condition
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
-> IO (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym
loop_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
inside_loop_frame)

    AfterFixpoint{} -> do
      -- break out of the loop
      ?logMessage::String -> IO ()
String -> IO ()
?logMessage String
"SimpleLoopFixpoint: SymbolicBranchState: AfterFixpoint"
      IORef (ExecutionFeatureContext sym wptr ext)
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (ExecutionFeatureContext sym wptr ext)
fixpoint_state_ref ((ExecutionFeatureContext sym wptr ext
  -> ExecutionFeatureContext sym wptr ext)
 -> IO ())
-> (ExecutionFeatureContext sym wptr ext
    -> ExecutionFeatureContext sym wptr ext)
-> IO ()
forall a b. (a -> b) -> a -> b
$ CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)) sym (wptr :: Nat) ext.
CallFrameHandle init ret blocks
-> ExecutionFeatureContext sym wptr ext
-> ExecutionFeatureContext sym wptr ext
callFrameContextPop CallFrameHandle init ret blocks
call_frame_handle
      Pred sym
not_loop_condition <- sym -> Pred sym -> IO (Pred sym)
forall sym. IsExprBuilder sym => sym -> Pred sym -> IO (Pred sym)
W4.notPred sym
sym Pred sym
loop_condition
      (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
-> IO (Pred sym, PausedFrame p sym ext rtp (CrucibleLang blocks r))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pred sym
not_loop_condition, PausedFrame p sym ext rtp (CrucibleLang blocks r)
outside_loop_frame)

  ProgramLoc
loc <- sym -> IO ProgramLoc
forall sym. IsExprBuilder sym => sym -> IO ProgramLoc
W4.getCurrentProgramLoc sym
sym
  bak -> Assumption sym -> IO ()
forall sym bak.
IsSymBackend sym bak =>
bak -> Assumption sym -> IO ()
C.addAssumption bak
bak (Assumption sym -> IO ()) -> Assumption sym -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramLoc -> Maybe ProgramLoc -> Pred sym -> Assumption sym
forall (e :: BaseType -> Type).
ProgramLoc
-> Maybe ProgramLoc -> e BaseBoolType -> CrucibleAssumption e
C.BranchCondition ProgramLoc
loc (PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> Maybe ProgramLoc
forall p sym ext rtp f.
PausedFrame p sym ext rtp f -> Maybe ProgramLoc
C.pausedLoc PausedFrame p sym ext rtp (CrucibleLang blocks r)
frame) Pred sym
condition
  ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
forall p sym ext rtp.
ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp
C.ExecutionFeatureNewState (ExecState p sym ext rtp -> ExecutionFeatureResult p sym ext rtp)
-> IO (ExecState p sym ext rtp)
-> IO (ExecutionFeatureResult p sym ext rtp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ReaderT
  (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
  IO
  (ExecState p sym ext rtp)
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> IO (ExecState p sym ext rtp)
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT
      (PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
-> ReaderT
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     IO
     (ExecState p sym ext rtp)
forall sym p ext rtp f g (ba :: Maybe (Ctx CrucibleType)).
IsSymInterface sym =>
PausedFrame p sym ext rtp f
-> ValueFromFrame p sym ext rtp f -> ExecCont p sym ext rtp g ba
C.resumeFrame (PausedFrame p sym ext rtp (CrucibleLang blocks r)
-> PausedFrame p sym ext rtp (CrucibleLang blocks r)
forall p sym ext rtp g.
PausedFrame p sym ext rtp g -> PausedFrame p sym ext rtp g
C.forgetPostdomFrame PausedFrame p sym ext rtp (CrucibleLang blocks r)
frame) (ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
 -> ReaderT
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
      IO
      (ExecState p sym ext rtp))
-> ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
-> ReaderT
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     IO
     (ExecState p sym ext rtp)
forall a b. (a -> b) -> a -> b
$ SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Getting
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
-> ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
forall s a. s -> Getting a s a -> a
^. ((ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Const
      (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
      (ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Const
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext rtp f1 (a :: Maybe (Ctx CrucibleType)) g
       (b :: Maybe (Ctx CrucibleType)) (f2 :: Type -> Type).
Functor f2 =>
(ActiveTree p sym ext rtp f1 a
 -> f2 (ActiveTree p sym ext rtp g b))
-> SimState p sym ext rtp f1 a -> f2 (SimState p sym ext rtp g b)
C.stateTree ((ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)
  -> Const
       (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
       (ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)))
 -> SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
 -> Const
      (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
      (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> ((ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
     -> Const
          (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
          (ValueFromFrame p sym ext rtp (CrucibleLang blocks r)))
    -> ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)
    -> Const
         (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
         (ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)))
-> Getting
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
     (SimState p sym ext rtp (CrucibleLang blocks r) ('Just args))
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValueFromFrame p sym ext rtp (CrucibleLang blocks r)
 -> Const
      (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
      (ValueFromFrame p sym ext rtp (CrucibleLang blocks r)))
-> ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args)
-> Const
     (ValueFromFrame p sym ext rtp (CrucibleLang blocks r))
     (ActiveTree p sym ext rtp (CrucibleLang blocks r) ('Just args))
forall p sym ext root f1 (args :: Maybe (Ctx CrucibleType))
       (f2 :: Type -> Type).
Functor f2 =>
(ValueFromFrame p sym ext root f1
 -> f2 (ValueFromFrame p sym ext root f1))
-> ActiveTree p sym ext root f1 args
-> f2 (ActiveTree p sym ext root f1 args)
C.actContext))
      SimState p sym ext rtp (CrucibleLang blocks r) ('Just args)
sim_state


data SomeCallFrameHandle ret blocks = forall init . SomeCallFrameHandle (CallFrameHandle init ret blocks)

callFrameHandle :: C.CallFrame sym ext blocks ret ctx -> SomeCallFrameHandle ret blocks
callFrameHandle :: forall sym ext (blocks :: Ctx (Ctx CrucibleType))
       (ret :: CrucibleType) (ctx :: Ctx CrucibleType).
CallFrame sym ext blocks ret ctx -> SomeCallFrameHandle ret blocks
callFrameHandle C.CallFrame { _frameCFG :: ()
_frameCFG = CFG ext blocks initialArgs ret
g } =
  CallFrameHandle initialArgs ret blocks
-> SomeCallFrameHandle ret blocks
forall (ret :: CrucibleType) (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType).
CallFrameHandle init ret blocks -> SomeCallFrameHandle ret blocks
SomeCallFrameHandle (CallFrameHandle initialArgs ret blocks
 -> SomeCallFrameHandle ret blocks)
-> CallFrameHandle initialArgs ret blocks
-> SomeCallFrameHandle ret blocks
forall a b. (a -> b) -> a -> b
$ FnHandle initialArgs ret
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle initialArgs ret blocks
forall (init :: Ctx CrucibleType) (ret :: CrucibleType)
       (blocks :: Ctx (Ctx CrucibleType)).
FnHandle init ret
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle init ret blocks
CallFrameHandle (CFG ext blocks initialArgs ret -> FnHandle initialArgs ret
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> FnHandle init ret
C.cfgHandle CFG ext blocks initialArgs ret
g) (Assignment (Assignment TypeRepr) blocks
 -> CallFrameHandle initialArgs ret blocks)
-> Assignment (Assignment TypeRepr) blocks
-> CallFrameHandle initialArgs ret blocks
forall a b. (a -> b) -> a -> b
$ (forall (x :: Ctx CrucibleType).
 Block ext blocks ret x -> Assignment TypeRepr x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment (Block ext blocks ret) x
   -> Assignment (Assignment TypeRepr) x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: Ctx CrucibleType -> Type)
       (g :: Ctx CrucibleType -> Type).
(forall (x :: Ctx CrucibleType). f x -> g x)
-> forall (x :: Ctx (Ctx CrucibleType)).
   Assignment f x -> Assignment g x
fmapFC Block ext blocks ret x -> CtxRepr x
forall ext (blocks :: Ctx (Ctx CrucibleType)) (ret :: CrucibleType)
       (ctx :: Ctx CrucibleType).
Block ext blocks ret ctx -> CtxRepr ctx
forall (x :: Ctx CrucibleType).
Block ext blocks ret x -> Assignment TypeRepr x
C.blockInputs (Assignment (Block ext blocks ret) blocks
 -> Assignment (Assignment TypeRepr) blocks)
-> Assignment (Block ext blocks ret) blocks
-> Assignment (Assignment TypeRepr) blocks
forall a b. (a -> b) -> a -> b
$ CFG ext blocks initialArgs ret
-> Assignment (Block ext blocks ret) blocks
forall ext (blocks :: Ctx (Ctx CrucibleType))
       (init :: Ctx CrucibleType) (ret :: CrucibleType).
CFG ext blocks init ret -> BlockMap ext blocks ret
C.cfgBlockMap CFG ext blocks initialArgs ret
g

data MaybePausedFrameTgtId f where
  JustPausedFrameTgtId :: C.Some (C.BlockID b) -> MaybePausedFrameTgtId (C.CrucibleLang b r)
  NothingPausedFrameTgtId :: MaybePausedFrameTgtId f

pausedFrameTgtId :: C.PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
pausedFrameTgtId :: forall p sym ext rtp f.
PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f
pausedFrameTgtId C.PausedFrame{ resume :: forall p sym ext rtp f.
PausedFrame p sym ext rtp f -> ControlResumption p sym ext rtp f
resume = ControlResumption p sym ext rtp f
resume } = case ControlResumption p sym ext rtp f
resume of
  C.ContinueResumption (C.ResolvedJump BlockID blocks args
tgt_id RegMap sym args
_) -> Some (BlockID blocks)
-> MaybePausedFrameTgtId (CrucibleLang blocks r)
forall (b :: Ctx (Ctx CrucibleType)) (r :: CrucibleType).
Some (BlockID b) -> MaybePausedFrameTgtId (CrucibleLang b r)
JustPausedFrameTgtId (Some (BlockID blocks)
 -> MaybePausedFrameTgtId (CrucibleLang blocks r))
-> Some (BlockID blocks)
-> MaybePausedFrameTgtId (CrucibleLang blocks r)
forall a b. (a -> b) -> a -> b
$ BlockID blocks args -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID blocks args
tgt_id
  C.CheckMergeResumption (C.ResolvedJump BlockID blocks args
tgt_id RegMap sym args
_) -> Some (BlockID blocks)
-> MaybePausedFrameTgtId (CrucibleLang blocks r)
forall (b :: Ctx (Ctx CrucibleType)) (r :: CrucibleType).
Some (BlockID b) -> MaybePausedFrameTgtId (CrucibleLang b r)
JustPausedFrameTgtId (Some (BlockID blocks)
 -> MaybePausedFrameTgtId (CrucibleLang blocks r))
-> Some (BlockID blocks)
-> MaybePausedFrameTgtId (CrucibleLang blocks r)
forall a b. (a -> b) -> a -> b
$ BlockID blocks args -> Some (BlockID blocks)
forall k (f :: k -> Type) (x :: k). f x -> Some f
C.Some BlockID blocks args
tgt_id
  ControlResumption p sym ext rtp f
_ -> MaybePausedFrameTgtId f
forall f. MaybePausedFrameTgtId f
NothingPausedFrameTgtId


applySubstitutionFC :: (OrdF k, FunctorFC f) => MapF k k -> f k l -> f k l
applySubstitutionFC :: forall {k} {l} (k :: k -> Type) (f :: (k -> Type) -> l -> Type)
       (l :: l).
(OrdF k, FunctorFC f) =>
MapF k k -> f k l -> f k l
applySubstitutionFC MapF k k
substitution = (forall (x :: k). k x -> k x) -> forall (x :: l). f k x -> f k x
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
forall (f :: k -> Type) (g :: k -> Type).
(forall (x :: k). f x -> g x) -> forall (x :: l). f f x -> f g x
fmapFC ((forall (x :: k). k x -> k x) -> forall (x :: l). f k x -> f k x)
-> (forall (x :: k). k x -> k x) -> forall (x :: l). f k x -> f k x
forall a b. (a -> b) -> a -> b
$ MapF k k -> k x -> k x
forall a (k :: a -> Type) (tp :: a).
OrdF k =>
MapF k k -> k tp -> k tp
findWithDefaultKey MapF k k
substitution

findWithDefaultKey :: forall a (k :: a -> Type) tp . OrdF k => MapF k k -> k tp -> k tp
findWithDefaultKey :: forall a (k :: a -> Type) (tp :: a).
OrdF k =>
MapF k k -> k tp -> k tp
findWithDefaultKey MapF k k
substitution k tp
key = k tp -> k tp -> MapF k k -> k tp
forall {v} (k :: v -> Type) (a :: v -> Type) (tp :: v).
OrdF k =>
a tp -> k tp -> MapF k a -> a tp
MapF.findWithDefault k tp
key k tp
key MapF k k
substitution

asBoundVarSubstitution :: W4.IsSymExprBuilder sym => sym ->  MapF (W4.SymExpr sym) a -> MapF (W4.BoundVar sym) a
asBoundVarSubstitution :: forall sym (a :: BaseType -> Type).
IsSymExprBuilder sym =>
sym -> MapF (SymExpr sym) a -> MapF (BoundVar sym) a
asBoundVarSubstitution sym
sym =
  [Pair (BoundVar sym) a] -> MapF (BoundVar sym) a
forall {v} (k :: v -> Type) (a :: v -> Type).
OrdF k =>
[Pair k a] -> MapF k a
MapF.fromList ([Pair (BoundVar sym) a] -> MapF (BoundVar sym) a)
-> (MapF (SymExpr sym) a -> [Pair (BoundVar sym) a])
-> MapF (SymExpr sym) a
-> MapF (BoundVar sym) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair (SymExpr sym) a -> Maybe (Pair (BoundVar sym) a))
-> [Pair (SymExpr sym) a] -> [Pair (BoundVar sym) a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(MapF.Pair SymExpr sym tp
k_expr a tp
v) -> (BoundVar sym tp -> Pair (BoundVar sym) a)
-> Maybe (BoundVar sym tp) -> Maybe (Pair (BoundVar sym) a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\BoundVar sym tp
k_var -> BoundVar sym tp -> a tp -> Pair (BoundVar sym) a
forall {k} (a :: k -> Type) (tp :: k) (b :: k -> Type).
a tp -> b tp -> Pair a b
MapF.Pair BoundVar sym tp
k_var a tp
v) (Maybe (BoundVar sym tp) -> Maybe (Pair (BoundVar sym) a))
-> Maybe (BoundVar sym tp) -> Maybe (Pair (BoundVar sym) a)
forall a b. (a -> b) -> a -> b
$ sym -> SymExpr sym tp -> Maybe (BoundVar sym tp)
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Maybe (BoundVar sym tp)
asBoundVar sym
sym SymExpr sym tp
k_expr) ([Pair (SymExpr sym) a] -> [Pair (BoundVar sym) a])
-> (MapF (SymExpr sym) a -> [Pair (SymExpr sym) a])
-> MapF (SymExpr sym) a
-> [Pair (BoundVar sym) a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MapF (SymExpr sym) a -> [Pair (SymExpr sym) a]
forall {k1} (k2 :: k1 -> Type) (a :: k1 -> Type).
MapF k2 a -> [Pair k2 a]
MapF.toList

asBoundVar :: W4.IsSymExprBuilder sym => sym -> W4.SymExpr sym tp -> Maybe (W4.BoundVar sym tp)
asBoundVar :: forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Maybe (BoundVar sym tp)
asBoundVar sym
sym SymExpr sym tp
expr = case Set (Some (BoundVar sym)) -> [Some (BoundVar sym)]
forall a. Set a -> [a]
Set.toList (sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
forall (tp :: BaseType).
sym -> SymExpr sym tp -> Set (Some (BoundVar sym))
W4.exprUninterpConstants sym
sym SymExpr sym tp
expr) of
  [Some BoundVar sym x
var]
    | Just tp :~: x
Refl <- SymExpr sym tp -> SymExpr sym x -> Maybe (tp :~: x)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BaseType) (b :: BaseType).
SymExpr sym a -> SymExpr sym b -> Maybe (a :~: b)
testEquality SymExpr sym tp
expr (sym -> BoundVar sym x -> SymExpr sym x
forall sym (tp :: BaseType).
IsSymExprBuilder sym =>
sym -> BoundVar sym tp -> SymExpr sym tp
forall (tp :: BaseType). sym -> BoundVar sym tp -> SymExpr sym tp
W4.varExpr sym
sym BoundVar sym x
var) ->
      BoundVar sym x -> Maybe (BoundVar sym x)
forall a. a -> Maybe a
Just BoundVar sym x
var
  [Some (BoundVar sym)]
_ -> Maybe (BoundVar sym tp)
forall a. Maybe a
Nothing

headAssumption :: sym -> C.Assumptions sym -> IO (C.CrucibleAssumption (W4.SymExpr sym))
headAssumption :: forall sym.
sym -> Assumptions sym -> IO (CrucibleAssumption (SymExpr sym))
headAssumption sym
sym = \case
  C.SingleAssumption CrucibleAssumption (SymExpr sym)
a -> CrucibleAssumption (SymExpr sym)
-> IO (CrucibleAssumption (SymExpr sym))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CrucibleAssumption (SymExpr sym)
a
  C.ManyAssumptions (Assumptions sym
x Seq.:<| Seq (Assumptions sym)
_) -> sym -> Assumptions sym -> IO (CrucibleAssumption (SymExpr sym))
forall sym.
sym -> Assumptions sym -> IO (CrucibleAssumption (SymExpr sym))
headAssumption sym
sym Assumptions sym
x
  Assumptions sym
_ -> String -> IO (CrucibleAssumption (SymExpr sym))
forall a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SimpleLoopFixpoint.headAssumption: empty assumptions"