packages feed

crucible-llvm (empty) → 0.6

raw patch · 64 files changed

+26875/−0 lines, 64 filesdep +attoparsecdep +basedep +bv-sized

Dependencies added: attoparsec, base, bv-sized, bytestring, containers, crucible, crucible-llvm, crucible-symio, directory, extra, filepath, itanium-abi, lens, llvm-pretty, llvm-pretty-bc-parser, mtl, parameterized-utils, pretty, prettyprinter, process, tasty, tasty-hunit, tasty-quickcheck, tasty-sugar, template-haskell, text, transformers, utf8-string, vector, what4

Files

+ CHANGELOG.md view
@@ -0,0 +1,67 @@+# 0.6 -- 2024-02-05++* `bindLLVMFunPtr` now accepts an `Text.LLVM.AST.Symbol` rather than a whole `Declare`.+  Use `decName` to get a `Symbol` from a `Declare`.+* Implement overrides for the LLVM `llvm.is.fpclass.f*` intrinsics.+* Implement overrides for the `isinf`, `__isinf`, and `__isinff` C functions.+* Implement overrides for the LLVM `llvm.fma.f*` and `llvm.fmuladd.f*`+  intrinsics.+* Implement overrides for the `fma` and `fmaf` C functions.+* Add a `Lang.Crucible.LLVM.MemModel.CallStack.null` function.+* Add a `ppLLVMLatest` function to `Lang.Crucible.LLVM.PrettyPrint`, which+  pretty-prints an LLVM AST using the latest LLVM version that `llvm-pretty`+  currently supports. Also add derived combinators (`ppDeclare`, `ppIdent`,+  etc.) for calling the `llvm-pretty` functions of the same names in tandem+  with `ppLLVMLatest`.++# 0.5+* Add `?memOpts :: MemOptions` constraints to the following functions:+  * `Lang.Crucible.LLVM.MemModel`: `doStore`, `storeRaw`, `condStoreRaw`, and+    `storeConstRaw`+  * `Lang.Crucible.LLVM.Globals`: `populateGlobal`+  * `Lang.Crucible.LLVM.MemModel.Generic`: `writeMem` and `writeConstMem`+* `Lang.Crucible.LLVM`: `registerModuleFn` has changed type to+  accomodate lazy loading of Crucible IR.+* `Lang.Crucible.LLVM.Translation` : The `ModuleTranslation` record is+  now opaque, the `cfgMap` is no longer exported and `globalInitMap`+  and `modTransNonce` have become lens-style getters instead of record+  accessors. CFGs should be retrieved using the new `getTranslatedCFG`+  or `getTranslatedCFGForHandle` functions.+* `Lang.Crucible.LLVM` : new functions `registerLazyModuleFn` and+  `registerLazyModule`, which delay the building of Crucible CFGs until+  the functions in question are actually called.+* `executeDirectives` in `Lang.Crucible.LLVM.Printf` now returns a `ByteString`+  instead of a `String` so that we can better preserve the exact bytes used in+  string arguments, without applying a particular text encoding.+* `crucible-llvm` now handles LLVM's opaque pointer types, an alternative+  representation of pointer types that does not store a pointee type. As a+  result, `MemType` now has an additional `PtrOpaqueType` constructor in+  addition to the existing (non-opaque) `PtrType` constructor.++  LLVM 15 and later use opaque pointers by default, so it is recommended that+  you add support for `PtrOpaqueType` (and opaque pointers in general) going+  forward. `crucible-llvm` still supports both kinds of pointers, so you can+  fall back to non-opaque pointers if need be.+* A new `Lang.Crucible.LLVM.SimpleLoopInvariant` module has been added, which+  provides an execution feature that facilitates reasoning about certain kinds+  of loops (which may not terminate) using loop invariants. Note that this+  functionality is very experimental and subject to change in the future.++# 0.4+* A new `indeterminateLoadBehavior` flag in `MemOptions` now controls now+  reading from uninitialized memory works when `laxLoadsAndStores` is enabled.+  If `StableSymbolic` is chosen, then allocating memory will also initialize it+  with a fresh symbolic value so that subsequent reads will always return that+  same value. If `UnstableSymbolic` is chosen, then each read from a section of+  uninitialized memory will return a distinct symbolic value each time.++  As a result of this change, `?memOpts :: MemOptions` constraints have been+  added to the following functions:+  * `Lang.Crucible.LLVM.Globals`:+    `initializeAllMemory`, `initializeMemoryConstGlobals`, `populateGlobals`,+    `populateAllGlobals`, and `populateConstGlobals`+  * `Lang.Crucible.LLVM.MemModel`:+    `doAlloca`, `doCalloc`, `doInvalidate`, `doMalloc`, `doMallocUnbounded`,+    `mallocRaw`, `mallocConstRaw`, `allocGlobals`, and `allocGlobal`+* `HasLLVMAnn` now has an additional `CallStack` argument, which is used for+  annotating errors with call stacks.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2022 Galois Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.++  * Neither the name of Galois, Inc. nor the names of its contributors+    may be used to endorse or promote products derived from this+    software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+This package implements an LLVM frontend for Crucible.  The frontend provides two major things:+1. A translation of LLVM IR into the Crucible IR+2. Data types supporting that translation++Most clients of the library that just want to analyze LLVM IR (which usually means C and C++) will only need the `Lang.Crucible.LLVM` and `Lang.Crucible.LLVM.Translation` modules.  The core data structure implementing the LLVM memory model (see `Lang.Crucible.LLVM.MemModel`) may be of interest to other clients.  The memory model is documented in more detail in [the docs](doc/memory-model.md).
+ crucible-llvm.cabal view
@@ -0,0 +1,150 @@+Cabal-version: 2.2+Name:          crucible-llvm+Version:       0.6+Author:        Galois Inc.+Copyright:     (c) Galois, Inc 2014-2022+Maintainer:    rscott@galois.com, kquick@galois.com, langston@galois.com+License:       BSD-3-Clause+License-file:  LICENSE+Build-type:    Simple+Category:      Language+Synopsis:      Support for translating and executing LLVM code in Crucible+Description:+   Library providing LLVM-specific extensions to the crucible core library+   for Crucible-based simulation and verification of LLVM-compiled applications.+extra-source-files: CHANGELOG.md, README.md++source-repository head+  type:     git+  location: https://github.com/GaloisInc/crucible+  subdir:   crucible-llvm++common bldflags+  ghc-options: -Wall+               -Werror=incomplete-patterns+               -Werror=missing-methods+               -Werror=overlapping-patterns+               -Wpartial-fields+               -Wincomplete-uni-patterns+  ghc-prof-options: -O2 -fprof-auto-exported+  default-language: Haskell2010+++library+  import: bldflags+  build-depends:+    base >= 4.13 && < 4.19,+    attoparsec,+    bv-sized >= 1.0.0,+    bytestring,+    containers >= 0.5.8.0,+    crucible >= 0.5,+    crucible-symio,+    what4 >= 0.4.1,+    extra,+    lens,+    itanium-abi >= 0.1.1.1 && < 0.2,+    llvm-pretty >= 0.12 && < 0.13,+    mtl,+    parameterized-utils >= 2.1.5 && < 2.2,+    pretty,+    prettyprinter >= 1.7.0,+    text,+    template-haskell,+    transformers,+    utf8-string,+    vector++  hs-source-dirs: src++  exposed-modules:+    Lang.Crucible.LLVM+    Lang.Crucible.LLVM.Arch.Util+    Lang.Crucible.LLVM.Arch.X86+    Lang.Crucible.LLVM.ArraySizeProfile+    Lang.Crucible.LLVM.Bytes+    Lang.Crucible.LLVM.Ctors+    Lang.Crucible.LLVM.DataLayout+    Lang.Crucible.LLVM.Errors+    Lang.Crucible.LLVM.Errors.MemoryError+    Lang.Crucible.LLVM.Errors.Poison+    Lang.Crucible.LLVM.Errors.UndefinedBehavior+    Lang.Crucible.LLVM.Eval+    Lang.Crucible.LLVM.Extension+    Lang.Crucible.LLVM.Globals+    Lang.Crucible.LLVM.Intrinsics+    Lang.Crucible.LLVM.Intrinsics.Libc+    Lang.Crucible.LLVM.Intrinsics.LLVM+    Lang.Crucible.LLVM.MalformedLLVMModule+    Lang.Crucible.LLVM.MemModel+    Lang.Crucible.LLVM.MemModel.CallStack+    Lang.Crucible.LLVM.MemModel.CallStack.Internal+    Lang.Crucible.LLVM.MemModel.Generic+    Lang.Crucible.LLVM.MemModel.MemLog+    Lang.Crucible.LLVM.MemModel.Partial+    Lang.Crucible.LLVM.MemModel.Pointer+    Lang.Crucible.LLVM.MemType+    Lang.Crucible.LLVM.PrettyPrint+    Lang.Crucible.LLVM.Printf+    Lang.Crucible.LLVM.QQ+    Lang.Crucible.LLVM.SymIO+    Lang.Crucible.LLVM.SimpleLoopFixpoint+    Lang.Crucible.LLVM.SimpleLoopInvariant+    Lang.Crucible.LLVM.Translation+    Lang.Crucible.LLVM.Translation.Aliases+    Lang.Crucible.LLVM.TypeContext++  other-modules:+    Lang.Crucible.LLVM.Errors.Standards+    Lang.Crucible.LLVM.Extension.Arch+    Lang.Crucible.LLVM.Extension.Syntax+    Lang.Crucible.LLVM.Intrinsics.Common+    Lang.Crucible.LLVM.Intrinsics.Libcxx+    Lang.Crucible.LLVM.Intrinsics.Options+    Lang.Crucible.LLVM.MemModel.Common+    Lang.Crucible.LLVM.MemModel.Options+    Lang.Crucible.LLVM.MemModel.Type+    Lang.Crucible.LLVM.MemModel.Value+    Lang.Crucible.LLVM.Translation.BlockInfo+    Lang.Crucible.LLVM.Translation.Constant+    Lang.Crucible.LLVM.Translation.Expr+    Lang.Crucible.LLVM.Translation.Instruction+    Lang.Crucible.LLVM.Translation.Monad+    Lang.Crucible.LLVM.Translation.Options+    Lang.Crucible.LLVM.Translation.Types+    Lang.Crucible.LLVM.Types+    Lang.Crucible.LLVM.Utils++  default-extensions: NoStarIsType+++test-suite crucible-llvm-tests+  import: bldflags+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  hs-source-dirs: test+  other-modules: MemSetup+               , TestFunctions+               , TestGlobals+               , TestMemory+               , TestTranslation+  build-depends:+    base,+    bv-sized,+    containers,+    crucible,+    crucible-llvm,+    directory,+    filepath,+    lens,+    llvm-pretty,+    llvm-pretty-bc-parser,+    lens,+    parameterized-utils,+    process,+    what4,+    tasty,+    tasty-quickcheck,+    tasty-hunit,+    tasty-sugar >= 2.0 && < 2.3,+    vector
+ src/Lang/Crucible/LLVM.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM+-- Description      : LLVM interface for Crucible+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : rdockins@galois.com+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM+  ( LLVM+  , registerModule+  , registerModuleFn+  , registerLazyModule+  , registerLazyModuleFn+  , llvmGlobalsToCtx+  , llvmGlobals+  , register_llvm_overrides+  , llvmExtensionImpl+  ) where++import           Control.Lens+import           Control.Monad (when)+import           Control.Monad.IO.Class+import qualified Text.LLVM.AST as L++import           Lang.Crucible.Analysis.Postdom+import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Core+import           Lang.Crucible.FunctionHandle+import           Lang.Crucible.LLVM.Eval (llvmExtensionEval)+import           Lang.Crucible.Panic (panic)+import           Lang.Crucible.LLVM.Extension (ArchWidth)+import           Lang.Crucible.LLVM.Intrinsics+import           Lang.Crucible.LLVM.MemModel+                   ( llvmStatementExec, HasPtrWidth, HasLLVMAnn, MemOptions, MemImpl+                   , Mem+                   )+import           Lang.Crucible.LLVM.Translation+import           Lang.Crucible.Simulator (regValue, FnVal(..))+import           Lang.Crucible.Simulator.ExecutionTree+import           Lang.Crucible.Simulator.GlobalState+import           Lang.Crucible.Simulator.OverrideSim+++import           What4.Interface (getCurrentProgramLoc)+import           What4.ProgramLoc (plSourceLoc)+++-- | Register all the functions defined in the LLVM module.+--   This will immediately build Crucible CFGs for each function+--   defined in the module.+registerModule ::+   (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) =>+   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} ->+   ModuleTranslation arch ->+   OverrideSim p sym LLVM rtp l a ()+registerModule handleWarning mtrans =+   mapM_ (registerModuleFn handleWarning mtrans) (map (L.decName.fst) (mtrans ^. modTransDefs))++-- | Register a specific named function that is defined in the given+--   module translation. This will immediately build a Crucible CFG for+--   the named function.+registerModuleFn ::+   (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) =>+   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} ->+   ModuleTranslation arch ->+   L.Symbol ->+   OverrideSim p sym LLVM rtp l a ()+registerModuleFn handleWarning mtrans sym =+  liftIO (getTranslatedCFG mtrans sym) >>= \case+    Nothing ->+      fail $ unlines+        [ "Could not find definition for function"+        , show sym+        ]+    Just (decl, AnyCFG cfg, warns) -> do+      let h = cfgHandle cfg+          s = UseCFG cfg (postdomInfo cfg)+      binds <- use (stateContext . functionBindings)+      let llvmCtx = mtrans ^. transContext+      bind_llvm_handle llvmCtx (L.decName decl) h s++      when (isJust $ lookupHandleMap h $ fnBindings binds) $+        do loc <- liftIO . getCurrentProgramLoc =<< getSymInterface+           liftIO (handleWarning (LLVMTranslationWarning sym (plSourceLoc loc) "LLVM function handle registered twice"))+      liftIO $ mapM_ handleWarning warns++-- | Lazily register all the functions defined in the LLVM module.  See+--   'registerLazyModuleFn' for a description.+registerLazyModule ::+   (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) =>+   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} ->+   ModuleTranslation arch ->+   OverrideSim p sym LLVM rtp l a ()+registerLazyModule handleWarning mtrans =+   mapM_ (registerLazyModuleFn handleWarning mtrans) (map (L.decName.fst) (mtrans ^. modTransDefs))++-- | Lazily register the named function that is defnied in the given module+--   translation. This will delay actually translating the function until it+--   is called. This done by first installing a bootstrapping override that+--   will peform the actual translation when first invoked, and then will backpatch+--   its own references to point to the translated function.+--+--   Note that the callback for printing translation warnings may be called at+--   a much-later point, when the function in question is actually first invoked.+registerLazyModuleFn ::+   (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) =>+   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling translation warnings -} ->+   ModuleTranslation arch ->+   L.Symbol ->+   OverrideSim p sym LLVM rtp l a ()+registerLazyModuleFn handleWarning mtrans sym =+  liftIO (getTranslatedFnHandle mtrans sym) >>= \case+    Nothing -> +      fail $ unlines+        [ "Could not find definition for function"+        , show sym+        ]+    Just (decl, SomeHandle h) ->+     do -- Bind the function handle we just created to the following bootstrapping code,+        -- which actually translates the function on its first execution and patches up+        -- behind itself.+        let s =+              UseOverride+              $ mkOverride' (handleName h) (handleReturnType h)+              $ -- This inner action defines what to do when this function is called for the+                -- first time.  We actually translate the function and install it as the+                -- implementation for the function handle, instead of this bootstrapping code.+                liftIO (getTranslatedCFG mtrans sym) >>= \case+                  Nothing ->+                    panic "registerLazyModuleFn"+                      [ "Could not find definition for function in bootstrapping code"+                      , show sym+                      ]+                  Just (_decl, AnyCFG cfg, warns) ->+                    case testEquality (handleType (cfgHandle cfg)) (handleType h) of+                      Nothing -> panic "registerLazyModuleFn"+                                      ["Translated CFG type does not match function handle type",+                                       show (handleType h), show (handleType (cfgHandle cfg)) ]+                      Just Refl ->+                        do liftIO $ mapM_ handleWarning warns+                           -- Here we rebind the function handle to use the translated CFG+                           bindFnHandle h (UseCFG cfg (postdomInfo cfg))+                           -- Now, make recursive call to ourself, which should invoke the+                           -- newly-installed CFG+                           regValue <$> (callFnVal (HandleFnVal h) =<< getOverrideArgs)+   +        -- Bind the function handle to the appropriate global symbol.+        let llvmCtx = mtrans ^. transContext+        bind_llvm_handle llvmCtx (L.decName decl) h s+++llvmGlobalsToCtx+   :: LLVMContext arch+   -> MemImpl sym+   -> SymGlobalState sym+llvmGlobalsToCtx = llvmGlobals . llvmMemVar++llvmGlobals+   :: GlobalVar Mem+   -> MemImpl sym+   -> SymGlobalState sym+llvmGlobals memVar mem = emptyGlobals & insertGlobal memVar mem++llvmExtensionImpl ::+  (HasLLVMAnn sym) =>+  MemOptions ->+  ExtensionImpl p sym LLVM+llvmExtensionImpl mo =+  let ?memOpts = mo in+  ExtensionImpl+  { extensionEval = llvmExtensionEval+  , extensionExec = llvmStatementExec+  }
+ src/Lang/Crucible/LLVM/Arch/Util.hs view
@@ -0,0 +1,6 @@+module Lang.Crucible.LLVM.Arch.Util where++++(|->) :: a -> b -> (a, b)+p |-> x = (p,x)
+ src/Lang/Crucible/LLVM/Arch/X86.hs view
@@ -0,0 +1,176 @@+{-# Language GADTs #-}+{-# Language DataKinds #-}+{-# Language KindSignatures #-}+{-# Language TypeOperators #-}+{-# Language ExplicitNamespaces #-}+{-# Language TemplateHaskell #-}+{-# Language RankNTypes #-}+{-# Language ScopedTypeVariables #-}+{-# Language PatternGuards #-}+{-# Language MultiWayIf #-}+module Lang.Crucible.LLVM.Arch.X86 where++import qualified Data.BitVector.Sized as BV+import Data.Word(Word8)+import Data.Bits+import Data.Kind+import GHC.TypeNats (type (<=))++import Data.Parameterized.NatRepr(knownNat)+import Data.Parameterized.Classes(testEquality,compareF)+import Data.Parameterized.TraversableFC+import Data.Parameterized.TH.GADT as U++import           What4.Interface (SymBV)+import qualified What4.Interface as I++import Lang.Crucible.CFG.Extension+import Lang.Crucible.Types(CrucibleType,BVType,NatRepr,TypeRepr(..))+import Lang.Crucible.Simulator.RegValue(RegValue)+import Lang.Crucible.Panic(panic)++import Lang.Crucible.LLVM.Arch.Util((|->))++data AVXOp1 = VShiftL Word8     -- ^ Shift left by this many bytes+                                -- New bytes are 0.+            | VShufD Word8      -- ^ Shuffle 32-bit words of vector+                                -- according to pattern in the word8+              deriving (Eq,Ord)+++data ExtX86 :: (CrucibleType -> Type) -> CrucibleType -> Type where++  {- | Unary operation on a vector.  Should have no side effects. -}+  VOp1 :: (1 <= n) =>+     !(NatRepr n)        -> {- width of input/result -}+     !AVXOp1             -> {- do this operation -}+     !(f (BVType n))     -> {- on this thing -}+     ExtX86 f (BVType n)++++eval :: forall sym f tp.+        I.IsSymExprBuilder sym =>+        sym ->+        (forall subT. f subT -> IO (RegValue sym subT)) ->+        ExtX86 f tp ->+        IO (RegValue sym tp)+eval sym ev ext =+  case ext of+    VOp1 w op e ->+      case op of+        VShiftL amt -> vShiftL sym w amt =<< ev e+        VShufD ixes -> vShufD sym w ixes =<< ev e+++-- | See @vpslldq@+vShiftL :: (I.IsSymExprBuilder sym, 1 <= w) =>+           sym -> NatRepr w -> Word8 -> SymBV sym w -> IO (SymBV sym w)+vShiftL sym w amt v =+  do i <- I.bvLit sym w (BV.mkBV w (8 * fromIntegral amt))+     I.bvShl sym v i+++-- | See @vpshufd@+vShufD :: forall sym w.+          I.IsSymExprBuilder sym =>+          sym -> NatRepr w -> Word8 -> SymBV sym w -> IO (SymBV sym w)+vShufD sym w ixes v+  | Just I.Refl <- testEquality w n128 = mk128 v+  | Just I.Refl <- testEquality w n256 =+    do lower128 <- mk128 =<< I.bvSelect sym n0   n128 v+       upper128 <- mk128 =<< I.bvSelect sym n128 n128 v+       I.bvConcat sym upper128 lower128+  | otherwise = panic "Arch.X86.vShufD"+                        [ "*** Unexpected width: " ++ show (I.natValue w) ]++  where+  mk128 :: SymBV sym 128 -> IO (SymBV sym 128)+  mk128 src = do f0 <- getV src 0+                 f1 <- getV src 1+                 f2 <- getV src 2+                 f3 <- getV src 3+                 lower64 <- I.bvConcat sym f1 f0+                 upper64 <- I.bvConcat sym f3 f2+                 I.bvConcat sym upper64 lower64++  getV :: SymBV sym 128 -> Int -> IO (SymBV sym 32)+  getV src n = case getIx n of+                 0 -> I.bvSelect sym n0 n32 src+                 1 -> I.bvSelect sym n1 n32 src+                 2 -> I.bvSelect sym n2 n32 src+                 _ -> I.bvSelect sym n3 n32 src++  getIx :: Int -> Word8+  getIx n = (ixes `shiftR` (2 * n)) .&. 0x03 -- get 2 bit field+++++--------------------------------------------------------------------------------+n0 :: NatRepr 0+n0 = knownNat++n1 :: NatRepr 1+n1 = knownNat++n2 :: NatRepr 2+n2 = knownNat++n3 :: NatRepr 3+n3 = knownNat++n32 :: NatRepr 32+n32 = knownNat++n128 :: NatRepr 128+n128 = knownNat++n256 :: NatRepr 256+n256 = knownNat+++--------------------------------------------------------------------------------++$([d| {- New TH Scope -} |])+++-- This is going to go away+instance ShowFC ExtX86 where+  showFC _ _ = error "[ShowFC ExtX86] Not implmented."++instance TestEqualityFC ExtX86 where+  testEqualityFC testSubterm =+    $(U.structuralTypeEquality [t| ExtX86 |]+        [ U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType |-> [|testEquality|]+        , U.DataArg 0             `U.TypeApp` U.AnyType |-> [|testSubterm|]+        ])++instance OrdFC ExtX86 where+  compareFC testSubterm =+    $(U.structuralTypeOrd [t| ExtX86 |]+        [ U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType |-> [|compareF|]+        , U.DataArg 0             `U.TypeApp` U.AnyType |-> [|testSubterm|]+        ])++-- This is going away+instance HashableFC ExtX86 where+  hashWithSaltFC _hash _s _x = error "[HashableFC ExtX86] Not implmented."++instance FunctorFC ExtX86 where+  fmapFC = fmapFCDefault++instance FoldableFC ExtX86 where+  foldMapFC = foldMapFCDefault++instance TraversableFC ExtX86 where+  traverseFC = $(U.structuralTraversal [t|ExtX86|] [])++instance PrettyApp ExtX86 where+  ppApp _pp _x = error "[PrettyApp ExtX86] XXX"++instance TypeApp ExtX86 where+  appType x =+    case x of+      VOp1 w _ _ -> BVRepr w+
+ src/Lang/Crucible/LLVM/ArraySizeProfile.hs view
@@ -0,0 +1,208 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.ArraySizeProfile+-- Description      : Execution feature to observe argument buffer sizes+-- Copyright        : (c) Galois, Inc 2020+-- License          : BSD3+-- Maintainer       : Samuel Breese <sbreese@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# Options -Wall #-}+{-# Language TemplateHaskell #-}+{-# Language OverloadedStrings #-}+{-# Language LambdaCase #-}+{-# Language MultiWayIf #-}+{-# Language ImplicitParams #-}+{-# Language ViewPatterns #-}+{-# Language PatternSynonyms #-}+{-# Language BangPatterns #-}+{-# Language FlexibleContexts #-}+{-# Language ScopedTypeVariables #-}+{-# Language DataKinds #-}+{-# Language KindSignatures #-}+{-# Language TypeFamilies #-}+{-# Language TypeApplications #-}+{-# Language GADTs #-}++module Lang.Crucible.LLVM.ArraySizeProfile+ ( FunctionProfile(..), funProfileName, funProfileArgs+ , ArgProfile(..), argProfileSize, argProfileInitialized+ , arraySizeProfile+ ) where++import Control.Lens.TH++import Control.Lens++import Data.Type.Equality (testEquality)+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import Data.Map (Map)+import qualified Data.Map as Map++import qualified Data.BitVector.Sized as BV+import Data.Parameterized.SymbolRepr+import qualified Data.Parameterized.Context as Ctx+import Data.Parameterized.TraversableFC++import qualified Lang.Crucible.Backend as C+import qualified Lang.Crucible.CFG.Core 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.Intrinsics as C+import qualified Lang.Crucible.Simulator.RegMap as C++import qualified Lang.Crucible.LLVM.DataLayout as C+import qualified Lang.Crucible.LLVM.Extension as C+import qualified Lang.Crucible.LLVM.MemModel as C+import qualified Lang.Crucible.LLVM.MemModel.Generic as G+import qualified Lang.Crucible.LLVM.Translation.Monad as C++import qualified What4.Interface as W4++------------------------------------------------------------------------+-- Profiles++data ArgProfile = ArgProfile+  { _argProfileSize :: Maybe Int+  , _argProfileInitialized :: Bool+  } deriving (Show, Eq, Ord)+makeLenses ''ArgProfile++data FunctionProfile = FunctionProfile+  { _funProfileName :: Text+  , _funProfileArgs :: [ArgProfile]+  } deriving (Show, Eq, Ord)+makeLenses ''FunctionProfile++------------------------------------------------------------------------+-- Learning a profile from an ExecState++ptrStartsAlloc ::+  W4.IsExpr (W4.SymExpr sym) =>+  C.LLVMPtr sym w ->+  Bool+ptrStartsAlloc (C.llvmPointerView -> (_, W4.asBV -> Just (BV.BV 0))) = True+ptrStartsAlloc _ = False++ptrAllocSize ::+  forall sym w.+  C.IsSymInterface sym =>+  G.Mem sym ->+  C.LLVMPtr sym w ->+  Maybe Int+ptrAllocSize mem (C.llvmPointerView -> (blk, _)) =+  do a <- W4.asNat blk+     G.AllocInfo _ msz _ _ _ <- G.possibleAllocInfo a (G.memAllocs mem)+     sz <- msz+     fromIntegral <$> BV.asUnsigned <$> W4.asBV sz++ptrArraySize ::+  C.IsSymInterface sym =>+  G.Mem sym ->+  C.LLVMPtr sym w ->+  Maybe Int+ptrArraySize mem ptr+  | ptrStartsAlloc ptr = ptrAllocSize mem ptr+  | otherwise = Nothing++ptrIsInitialized ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w+  , ?memOpts :: C.MemOptions ) =>+  sym ->+  G.Mem sym ->+  C.LLVMPtr sym w ->+  IO Bool+ptrIsInitialized sym mem ptr =+  G.readMem sym C.PtrWidth Nothing ptr (C.bitvectorType 1) C.noAlignment mem >>= \case+  C.NoErr{} -> pure True+  _ -> pure False++intrinsicArgProfile ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w+  , ?memOpts :: C.MemOptions ) =>+  sym ->+  G.Mem sym ->+  SymbolRepr nm ->+  C.CtxRepr ctx ->+  C.Intrinsic sym nm ctx ->+  IO ArgProfile+intrinsicArgProfile sym mem+  (testEquality (knownSymbol :: SymbolRepr "LLVM_pointer") -> Just Refl)+  (Ctx.Empty Ctx.:> C.BVRepr (testEquality ?ptrWidth -> Just Refl)) i =+   ArgProfile (ptrArraySize mem i) <$> ptrIsInitialized sym mem i+intrinsicArgProfile _ _ _ _ _ = pure $ ArgProfile Nothing False++regValueArgProfile ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w+  , ?memOpts :: C.MemOptions ) =>+  sym ->+  G.Mem sym ->+  C.TypeRepr tp ->+  C.RegValue sym tp ->+  IO ArgProfile+regValueArgProfile sym mem (C.IntrinsicRepr nm ctx) i = intrinsicArgProfile sym mem nm ctx i+regValueArgProfile _ _ _ _ = pure $ ArgProfile Nothing False++regEntryArgProfile ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w+  , ?memOpts :: C.MemOptions ) =>+  sym ->+  G.Mem sym ->+  C.RegEntry sym tp ->+  IO ArgProfile+regEntryArgProfile sym mem (C.RegEntry t v) = regValueArgProfile sym mem t v++newtype Wrap a (b :: C.CrucibleType) = Wrap { unwrap :: a }+argProfiles ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w+  , ?memOpts :: C.MemOptions ) =>+  sym ->+  G.Mem sym ->+  Ctx.Assignment (C.RegEntry sym) ctx ->+  IO [ArgProfile]+argProfiles sym mem as =+  sequence (Vector.toList $ Ctx.toVector (fmapFC (Wrap . regEntryArgProfile sym mem) as) unwrap)++------------------------------------------------------------------------+-- Execution feature for learning profiles++updateProfiles ::+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth (C.ArchWidth arch)+  , ?memOpts :: C.MemOptions ) =>+  C.LLVMContext arch ->+  IORef (Map Text [FunctionProfile]) ->+  C.ExecState p sym ext rtp ->+  IO ()+updateProfiles llvm cell state+  | C.CallState _ (C.CrucibleCall _ frame) sim <- state+  , C.CallFrame { C._frameCFG = cfg, C._frameRegs = regs } <- frame+  , Just mem <- C.memImplHeap <$> C.lookupGlobal (C.llvmMemVar llvm) (sim ^. C.stateGlobals)+  = do+      argProfs <- argProfiles (sim ^. C.stateSymInterface) mem $ C.regMap regs+      modifyIORef' cell $ \profs ->+        let name = Text.pack . show $ C.cfgHandle cfg+            funProf = FunctionProfile name argProfs+        in case Map.lookup name profs of+             Nothing -> Map.insert name [funProf] profs+             Just variants+               | funProf `elem` variants -> profs+               | otherwise -> Map.insert name (funProf:variants) profs+  | otherwise = pure ()++arraySizeProfile ::+  forall sym ext arch p rtp.+  ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth (C.ArchWidth arch)+  , ?memOpts :: C.MemOptions ) =>+  C.LLVMContext arch ->+  IORef (Map Text [FunctionProfile]) ->+  IO (C.ExecutionFeature p sym ext rtp)+arraySizeProfile llvm profiles = do+  pure . C.ExecutionFeature $ \s -> do+    updateProfiles llvm profiles s+    pure C.ExecutionFeatureNoChange
+ src/Lang/Crucible/LLVM/Bytes.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Bytes+-- Description      : A type representing numbers of bytes.+-- Copyright        : (c) Galois, Inc 2011-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Lang.Crucible.LLVM.Bytes+  ( -- * Bytes+    Bytes(..)+  , Addr+  , Offset+  , bytesToBits+  , bytesToNatural+  , bytesToInteger+  , bytesToBV+  , toBytes+  , bitsToBytes+  , natBytesMul+  )  where++import qualified Data.BitVector.Sized as BV+import Data.Parameterized.NatRepr+import Numeric.Natural++-- | A newtype for expressing numbers of bytes.+--   This newtype is explicitly introduced to avoid confusion+--   between widths expressed as numbers of bits vs numbers of bytes.+newtype Bytes = Bytes { unBytes :: Integer }+  deriving (Eq, Ord, Num, Enum, Real, Integral)++instance Show Bytes where+  show (Bytes n) = show n++bytesToBits :: Bytes -> Natural+bytesToBits (Bytes n) = 8 * fromIntegral n++bytesToNatural :: Bytes -> Natural+bytesToNatural (Bytes n) = fromIntegral n++bytesToInteger :: Bytes -> Integer+bytesToInteger (Bytes n) = n++bytesToBV :: NatRepr w -> Bytes -> BV.BV w+bytesToBV w = BV.mkBV w . bytesToInteger++toBytes :: Integral a => a -> Bytes+toBytes = Bytes . fromIntegral++bitsToBytes :: Integral a => a -> Bytes+bitsToBytes n = Bytes ( (fromIntegral n + 7) `div` 8 )++-- | Multiply a number of bytes by a natural number+natBytesMul :: Natural -> Bytes -> Bytes+natBytesMul n (Bytes x) = Bytes (toInteger n * x)++type Addr = Bytes+type Offset = Bytes
+ src/Lang/Crucible/LLVM/Ctors.hs view
@@ -0,0 +1,190 @@+ ------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Ctors+-- Description      : Extract and manipulate the @llvm.global_ctors@ variable+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++module Lang.Crucible.LLVM.Ctors+  ( Ctor(..)+  , globalCtors+  , callCtors+  , callAllCtors+  , callCtorsCFG+  ) where++import           Data.Data (Data)+import           Data.IORef (newIORef)+import           Data.String(fromString)+import           Data.Typeable (Typeable)+import qualified Data.Text as Text+import           GHC.Generics (Generic)+import           Data.Parameterized.Nonce++import           Control.Monad (forM, forM_)+import           Control.Monad.Except (MonadError(..))+import           Data.List (find, sortBy)+import           Data.Ord (comparing, Down(..))+import           Data.Maybe (fromMaybe)++import qualified Text.LLVM.AST as L++import           Lang.Crucible.LLVM.Translation.Instruction (callOrdinaryFunction)+import           Lang.Crucible.LLVM.Translation.Monad (LLVMGenerator, LLVMState(..))++-- Generating CFGs++import           Data.Map.Strict (empty)+import           Data.Text (Text)+import           GHC.TypeNats++import qualified Data.Parameterized.Context.Unsafe as Ctx++import           What4.FunctionName (functionNameFromText)+import           What4.ProgramLoc (Position(InternalPos))++import qualified Lang.Crucible.CFG.Core as Core+import           Lang.Crucible.CFG.Expr (App(EmptyApp))+import           Lang.Crucible.CFG.Generator (FunctionDef, defineFunction)+import           Lang.Crucible.CFG.Reg (Expr(App))+import qualified Lang.Crucible.CFG.Reg as Reg+import           Lang.Crucible.CFG.SSAConversion (toSSA)+import           Lang.Crucible.FunctionHandle (HandleAllocator, mkHandle')+import           Lang.Crucible.Types (UnitType, TypeRepr(UnitRepr))+import           Lang.Crucible.LLVM.Extension (LLVM, ArchWidth)+import           Lang.Crucible.LLVM.Translation.Monad (LLVMContext, _llvmTypeCtx, malformedLLVMModule)+import           Lang.Crucible.LLVM.Types (HasPtrWidth)++{- Example:++@llvm.global_ctors = appending global [3 x { i32, void ()*, i8* }] [{ i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_HkdfTest.cpp, i8* null }, { i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_gtest_all.cc, i8* null }, { i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_iostream.cpp, i8* null }]++-}++-- | A representation of well-typed inhabitants of the @llvm.global_ctors@ array+--+-- See https://llvm.org/docs/LangRef.html#the-llvm-global-ctors-global-variable+data Ctor = Ctor+  { ctorPriority :: Integer+  , ctorFunction :: L.Symbol+  , ctorData     :: Maybe L.Symbol+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- | Get the global variable representing @llvm.global_ctors@.+getGlobalCtorsGlobal :: L.Module -> Maybe L.Global+getGlobalCtorsGlobal mod_ =+  let symb = L.Symbol "llvm.global_ctors"+  in find (\x -> L.globalSym x == symb) (L.modGlobals mod_)++-- | Unpack a @ctors@ value of type @{ i32, void ()*, i8* }@ from the AST+extractCtors :: L.Value -> Maybe Ctor+extractCtors val =+  case val of+    -- This is permissive about the integer widths... No reason to get caught up.+    L.ValStruct [ L.Typed (L.PrimType (L.Integer _w0)) (L.ValInteger priority)+                , L.Typed (L.PtrTo (L.FunTy (L.PrimType L.Void) [] _bool)) (L.ValSymbol symb)+                , L.Typed (L.PtrTo (L.PrimType (L.Integer _w1))) data0_+                ] -> Just . Ctor priority symb $+                       case data0_ of+                         L.ValSymbol data_ -> Just data_+                         _                 -> Nothing+    _ -> Nothing++-- | Unpack and sort the values in @llvm.global_ctors@ by priority+globalCtors :: (MonadError String m)+            => L.Module+            -> m [Ctor]+globalCtors mod_ =+  case getGlobalCtorsGlobal mod_ >>= L.globalValue of -- in the Maybe monad+    Just (L.ValArray _ty vs) -> do++      -- Assert that each value is of the expected type.+      vs' <- forM vs $ \v ->+        fromMaybe+          (throwError $ unlines $ [ "Ill-typed value in llvm.global_ctors: "+                                  , show v+                                  ])+          (pure <$> extractCtors v)++      -- Sort the values by priority, highest to lowest.+      pure (sortBy (comparing (Down . ctorPriority)) vs')++    -- @llvm.ctors value not found, assume there are no global_ctors to run+    Nothing -> return []++    Just v  -> throwError $ unlines $+      [ "llvm.global_ctors wasn't an array"+      , "Value: " ++ show v+      ]++----------------------------------------------------------------------+-- ** callCtors++-- | Call some or all of the functions in @llvm.global_ctors@+callCtors :: (Ctor -> Bool) -- ^ Filter function+          -> L.Module+          -> LLVMGenerator s arch UnitType (Expr LLVM s UnitType)+callCtors select mod_ = do+  let err msg = malformedLLVMModule "Error loading @llvm.global_ctors" [fromString msg]+  let ty = L.FunTy (L.PrimType L.Void) [] False++  ctors <- either err (pure . filter select) (globalCtors mod_)+  forM_ ctors $ \ctor ->+    callOrdinaryFunction Nothing False ty (L.ValSymbol (ctorFunction ctor)) [] (\_ -> pure ())+  return (App EmptyApp)++-- | Call each function in @llvm.global_ctors@ in order of decreasing priority+callAllCtors :: L.Module -> LLVMGenerator s arch UnitType (Expr LLVM s UnitType)+callAllCtors = callCtors (const True)++----------------------------------------------------------------------+-- ** callCtorsCFG++-- | Make a 'LLVMGenerator' into a CFG by making it a function with no arguments+-- that returns unit.+generatorToCFG :: forall arch wptr ret. (HasPtrWidth wptr, wptr ~ ArchWidth arch, 16 <= wptr)+               => Text+               -> HandleAllocator+               -> LLVMContext arch+               -> (forall s. LLVMGenerator s arch ret (Expr LLVM s ret))+               -> TypeRepr ret+               -> IO (Core.SomeCFG LLVM Core.EmptyCtx ret)+generatorToCFG name halloc llvmctx gen ret = do+  ref <- newIORef []+  let ?lc = _llvmTypeCtx llvmctx+  let def :: forall args. FunctionDef LLVM (LLVMState arch) args ret IO+      def _inputs = (state, gen)+        where state = LLVMState { _identMap     = empty+                                , _blockInfoMap = empty+                                , llvmContext   = llvmctx+                                , _translationWarnings = ref+                                , _functionSymbol = L.Symbol (Text.unpack name)+                                }++  hand <- mkHandle' halloc (functionNameFromText name) Ctx.empty ret+  sng <- newIONonceGenerator+  (Reg.SomeCFG g, []) <- defineFunction InternalPos sng hand def+  return $! toSSA g++-- | Create a CFG that calls some of the functions in @llvm.global_ctors@.+callCtorsCFG :: forall arch wptr. (HasPtrWidth wptr, wptr ~ ArchWidth arch, 16 <= wptr)+             => (Ctor -> Bool) -- ^ Filter function+             -> L.Module+             -> HandleAllocator+             -> LLVMContext arch+             -> IO (Core.SomeCFG LLVM Core.EmptyCtx UnitType)+callCtorsCFG select mod_ halloc llvmctx = do+  generatorToCFG "llvm_global_ctors" halloc llvmctx (callCtors select mod_) UnitRepr
+ src/Lang/Crucible/LLVM/DataLayout.hs view
@@ -0,0 +1,333 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.DataLayout+-- Description      : Basic datatypes for describing memory layout and alignment+-- Copyright        : (c) Galois, Inc 2011-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.DataLayout+  ( -- * Alignments+    Alignment+  , noAlignment+  , padToAlignment+  , toAlignment+  , fromAlignment+  , exponentToAlignment+  , alignmentToExponent+    -- * Data layout declarations.+  , DataLayout+  , EndianForm(..)+  , intLayout+  , maxAlignment+  , ptrSize+  , ptrAlign+  , ptrBitwidth+  , defaultDataLayout+  , parseDataLayout+  , integerAlignment+  , vectorAlignment+  , floatAlignment+  , aggregateAlignment+  , intWidthSize+  ) where++import Control.Lens+import Control.Monad.State.Strict+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Word (Word32)+import qualified Text.LLVM as L+import Numeric.Natural++import What4.Utils.Arithmetic+import Lang.Crucible.LLVM.Bytes+++------------------------------------------------------------------------+-- Data layout++-- | An @Alignment@ represents a number of bytes that must be a power of two.+newtype Alignment = Alignment Word32+  deriving (Eq, Ord, Show)+-- The representation just stores the exponent. E.g., @Alignment 3@+-- indicates alignment to a 2^3-byte boundary.++-- | 1-byte alignment, which is the minimum possible.+noAlignment :: Alignment+noAlignment = Alignment 0++-- | @padToAlignment x a@ returns the smallest value greater than or+-- equal to @x@ that is aligned to @a@.+padToAlignment :: Bytes -> Alignment -> Bytes+padToAlignment x (Alignment n) = toBytes (nextPow2Multiple (bytesToNatural x) (fromIntegral n))++-- | Convert a number of bytes into an alignment, if it is a power of 2.+toAlignment :: Bytes -> Maybe Alignment+toAlignment (Bytes x)+  | isPow2 x = Just (Alignment (fromIntegral (lg x)))+  | otherwise = Nothing++-- | Convert an alignment to a number of bytes.+fromAlignment :: Alignment -> Bytes+fromAlignment (Alignment n) = Bytes (2 ^ n)++-- | Convert an exponent @n@ to an alignment of @2^n@ bytes.+exponentToAlignment :: Natural -> Alignment+exponentToAlignment n = Alignment (fromIntegral n)++alignmentToExponent :: Alignment -> Natural+alignmentToExponent (Alignment n) = fromIntegral n++newtype AlignInfo = AT (Map Natural Alignment)+  deriving (Eq, Ord)++-- | Make alignment info containing no alignments.+emptyAlignInfo :: AlignInfo+emptyAlignInfo = AT Map.empty++-- | Return alignment exactly at point if any.+findExact :: Natural -> AlignInfo -> Maybe Alignment+findExact w (AT t) = Map.lookup w t++-- | Get alignment for the integer type of the specified bitwidth,+-- using LLVM's rules for integer types: "If no match is found, and+-- the type sought is an integer type, then the smallest integer type+-- that is larger than the bitwidth of the sought type is used. If+-- none of the specifications are larger than the bitwidth then the+-- largest integer type is used."+-- <http://llvm.org/docs/LangRef.html#langref-datalayout>+integerAlignment :: DataLayout -> Natural -> Alignment+integerAlignment dl w =+  case Map.lookupGE w t of+    Just (_, a) -> a+    Nothing ->+      case Map.toDescList t of+        ((_, a) : _) -> a+        _ -> noAlignment+  where AT t = dl^.integerInfo++-- | Get alignment for a vector type of the specified bitwidth, using+-- LLVM's rules for vector types: "If no match is found, and the type+-- sought is a vector type, then the largest vector type that is+-- smaller than the sought vector type will be used as a fall back."+-- <http://llvm.org/docs/LangRef.html#langref-datalayout>+vectorAlignment :: DataLayout -> Natural -> Alignment+vectorAlignment dl w =+  case Map.lookupLE w t of+    Just (_, a) -> a+    Nothing -> noAlignment+  where AT t = dl^.vectorInfo++-- | Get alignment for a float type of the specified bitwidth.+floatAlignment :: DataLayout -> Natural -> Maybe Alignment+floatAlignment dl w = Map.lookup w t+  where AT t = dl^.floatInfo++-- | Get the basic alignment for aggregate types.+aggregateAlignment :: DataLayout -> Alignment+aggregateAlignment dl =+  fromMaybe noAlignment (findExact 0 (dl^.aggInfo))++-- | Return maximum alignment constraint stored in tree.+maxAlignmentInTree :: AlignInfo -> Alignment+maxAlignmentInTree (AT t) = foldrOf folded max noAlignment t++-- | Update alignment tree+updateAlign :: Natural+            -> AlignInfo+            -> Maybe Alignment+            -> AlignInfo+updateAlign w (AT t) ma = AT (Map.alter (const ma) w t)++type instance Index AlignInfo = Natural+type instance IxValue AlignInfo = Alignment++instance Ixed AlignInfo where+  ix k = at k . traverse++instance At AlignInfo where+  at k f m = updateAlign k m <$> indexed f k (findExact k m)++-- | Flags byte orientation of target machine.+data EndianForm = BigEndian | LittleEndian+  deriving (Eq, Ord, Show)++-- | Parsed data layout+data DataLayout+   = DL { _intLayout :: EndianForm+        , _stackAlignment :: !Alignment+        , _ptrSize     :: !Bytes+        , _ptrAlign    :: !Alignment+        , _integerInfo :: !AlignInfo+        , _vectorInfo  :: !AlignInfo+        , _floatInfo   :: !AlignInfo+        , _aggInfo     :: !AlignInfo+        , _stackInfo   :: !AlignInfo+        , _layoutWarnings :: [L.LayoutSpec]+        }+  deriving (Eq, Ord)++instance Show DataLayout where+   show _ = "<<DataLayout>>"++intLayout :: Lens' DataLayout EndianForm+intLayout = lens _intLayout (\s v -> s { _intLayout = v})++stackAlignment :: Lens' DataLayout Alignment+stackAlignment = lens _stackAlignment (\s v -> s { _stackAlignment = v})++-- | Size of pointers in bytes.+ptrSize :: Lens' DataLayout Bytes+ptrSize = lens _ptrSize (\s v -> s { _ptrSize = v})++-- | ABI pointer alignment in bytes.+ptrAlign :: Lens' DataLayout Alignment+ptrAlign = lens _ptrAlign (\s v -> s { _ptrAlign = v})++integerInfo :: Lens' DataLayout AlignInfo+integerInfo = lens _integerInfo (\s v -> s { _integerInfo = v})++vectorInfo :: Lens' DataLayout AlignInfo+vectorInfo = lens _vectorInfo (\s v -> s { _vectorInfo = v})++floatInfo :: Lens' DataLayout AlignInfo+floatInfo = lens _floatInfo (\s v -> s { _floatInfo = v})++-- | Information about aggregate size.+aggInfo :: Lens' DataLayout AlignInfo+aggInfo = lens _aggInfo (\s v -> s { _aggInfo = v})++-- | Layout constraints on a stack object with the given size.+stackInfo :: Lens' DataLayout AlignInfo+stackInfo = lens _stackInfo (\s v -> s { _stackInfo = v})++-- | Layout specs that could not be parsed.+layoutWarnings :: Lens' DataLayout [L.LayoutSpec]+layoutWarnings = lens _layoutWarnings (\s v -> s { _layoutWarnings = v})++ptrBitwidth :: DataLayout -> Natural+ptrBitwidth dl = bytesToBits (dl^.ptrSize)++-- | Reduce the bit level alignment to a byte value, and error if it is not+-- a multiple of 8.+fromBits :: Int -> Either String Alignment+fromBits a | w <= 0 = Left $ "Alignment must be a positive number."+           | r /= 0 = Left $ "Alignment specification must occupy a byte boundary."+           | not (isPow2 w) = Left $ "Alignment must be a power of two."+           | otherwise = Right $ Alignment (fromIntegral (lg w))+  where (w,r) = toInteger a `divMod` 8++-- | Insert alignment into spec.+setAt :: Lens' DataLayout AlignInfo -> Natural -> Alignment -> State DataLayout ()+setAt f sz a = f . at sz ?= a++-- | The default data layout if no spec is defined. From the LLVM+-- Language Reference: "When constructing the data layout for a given+-- target, LLVM starts with a default set of specifications which are+-- then (possibly) overridden by the specifications in the datalayout+-- keyword." <http://llvm.org/docs/LangRef.html#langref-datalayout>+defaultDataLayout :: DataLayout+defaultDataLayout = execState defaults dl+  where dl = DL { _intLayout = BigEndian+                , _stackAlignment = noAlignment+                , _ptrSize  = 8 -- 64 bit pointers = 8 bytes+                , _ptrAlign = Alignment 3 -- 64 bit alignment: 2^3=8 byte boundaries+                , _integerInfo = emptyAlignInfo+                , _floatInfo   = emptyAlignInfo+                , _vectorInfo  = emptyAlignInfo+                , _aggInfo     = emptyAlignInfo+                , _stackInfo   = emptyAlignInfo+                , _layoutWarnings = []+                }+        defaults = do+          -- Default integer alignments+          setAt integerInfo  1 noAlignment -- 1-bit values aligned on byte addresses.+          setAt integerInfo  8 noAlignment -- 8-bit values aligned on byte addresses.+          setAt integerInfo 16 (Alignment 1) -- 16-bit values aligned on 2 byte addresses.+          setAt integerInfo 32 (Alignment 2) -- 32-bit values aligned on 4 byte addresses.+          setAt integerInfo 64 (Alignment 3) -- 64-bit values aligned on 8 byte addresses.+          -- Default float alignments+          setAt floatInfo  16 (Alignment 1) -- Half is aligned on 2 byte addresses.+          setAt floatInfo  32 (Alignment 2) -- Float is aligned on 4 byte addresses.+          setAt floatInfo  64 (Alignment 3) -- Double is aligned on 8 byte addresses.+          setAt floatInfo 128 (Alignment 4) -- Quad is aligned on 16 byte addresses.+          -- Default vector alignments.+          setAt vectorInfo  64 (Alignment 3) -- 64-bit vector is 8 byte aligned.+          setAt vectorInfo 128 (Alignment 4) -- 128-bit vector is 16 byte aligned.+          -- Default aggregate alignments.+          setAt aggInfo  0 noAlignment  -- Aggregates are 1-byte aligned.++-- | Maximum alignment for any type (used by malloc).+maxAlignment :: DataLayout -> Alignment+maxAlignment dl =+  maximum [ dl^.stackAlignment+          , dl^.ptrAlign+          , maxAlignmentInTree (dl^.integerInfo)+          , maxAlignmentInTree (dl^.vectorInfo)+          , maxAlignmentInTree (dl^.floatInfo)+          , maxAlignmentInTree (dl^.aggInfo)+          , maxAlignmentInTree (dl^.stackInfo)+          ]++fromSize :: Int -> Natural+fromSize i | i < 0 = error $ "Negative size given in data layout."+           | otherwise = fromIntegral i++-- | Insert alignment into spec.+setAtBits :: Lens' DataLayout AlignInfo -> L.LayoutSpec -> Int -> Int -> State DataLayout ()+setAtBits f spec sz a =+  case fromBits a of+    Left{} -> layoutWarnings %= (spec:)+    Right w -> f . at (fromSize sz) .= Just w++-- | Insert alignment into spec.+setBits :: Lens' DataLayout Alignment -> L.LayoutSpec -> Int -> State DataLayout ()+setBits f spec a =+  case fromBits a of+    Left{} -> layoutWarnings %= (spec:)+    Right w -> f .= w++-- | Add information from layout spec into parsed data layout.+addLayoutSpec :: L.LayoutSpec -> State DataLayout ()+addLayoutSpec ls =+  -- TODO: Check that sizes and alignment is using bits versus bytes consistently.+    case ls of+      L.BigEndian    -> intLayout .= BigEndian+      L.LittleEndian -> intLayout .= LittleEndian+      L.PointerSize n sz a _+           -- Currently, we assume that only default address space (0) is used.+           -- We use that address space as the sole arbiter of what pointer+           -- size to use, and we ignore all other PointerSize layout specs.+           -- See doc/limitations.md for more discussion.+        |  n == 0+        -> case fromBits a of+             Right a' | r == 0 -> do ptrSize .= fromIntegral w+                                     ptrAlign .= a'+             _ -> layoutWarnings %= (ls:)+        |  otherwise+        -> return ()+       where (w,r) = sz `divMod` 8+      L.IntegerSize    sz a _ -> setAtBits integerInfo ls sz a+      L.VectorSize     sz a _ -> setAtBits vectorInfo  ls sz a+      L.FloatSize      sz a _ -> setAtBits floatInfo   ls sz a+      L.AggregateSize  sz a _ -> setAtBits aggInfo     ls sz a+      L.StackObjSize   sz a _ -> setAtBits stackInfo   ls sz a+      L.NativeIntSize _ -> return ()+      L.StackAlign a    -> setBits stackAlignment ls a+      L.Mangling _      -> return ()++-- | Create parsed data layout from layout spec AST.+parseDataLayout :: L.DataLayout -> DataLayout+parseDataLayout dl = execState (mapM_ addLayoutSpec dl) defaultDataLayout++-- | The size of an integer of the given bitwidth, in bytes.+intWidthSize :: Natural -> Bytes+intWidthSize w = bitsToBytes w
+ src/Lang/Crucible/LLVM/Errors.hs view
@@ -0,0 +1,151 @@+-- |+-- Module           : Lang.Crucible.LLVM.Errors+-- Description      : Safety assertions for the LLVM syntax extension+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Langston Barrett <lbarrett@galois.com>+-- Stability        : provisional+--+--------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM.Errors+  ( LLVMSafetyAssertion+  , BadBehavior(..)+  , undefinedBehavior+  , undefinedBehavior'+  , poison+  , poison'+  , memoryError+  , detailBB+  , explainBB+  , ppBB+  , concBadBehavior+    -- ** Lenses+  , classifier+  , predicate+  , extra+  ) where++import           Prelude hiding (pred)++import           Control.Lens+import           Data.Text (Text)++import           Data.Typeable (Typeable)+import           GHC.Generics (Generic)+import           Prettyprinter++import           What4.Interface+import           What4.Expr (GroundValue)++import           Lang.Crucible.Simulator.RegValue (RegValue'(..))+import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME+import qualified Lang.Crucible.LLVM.Errors.Poison as Poison+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB++-- -----------------------------------------------------------------------+-- ** BadBehavior++-- | Combine the three types of bad behaviors+--+data BadBehavior sym where+  BBUndefinedBehavior :: UB.UndefinedBehavior (RegValue' sym) -> BadBehavior sym+  BBMemoryError       :: ME.MemoryError sym -> BadBehavior sym+ deriving Typeable++concBadBehavior ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  BadBehavior sym -> IO (BadBehavior sym)+concBadBehavior sym conc (BBUndefinedBehavior ub) =+  BBUndefinedBehavior <$> UB.concUB sym conc ub+concBadBehavior sym conc (BBMemoryError me) =+  BBMemoryError <$> ME.concMemoryError sym conc me++-- -----------------------------------------------------------------------+-- ** LLVMSafetyAssertion++data LLVMSafetyAssertion sym =+  LLVMSafetyAssertion+    { _classifier :: BadBehavior sym -- ^ What could have gone wrong?+    , _predicate  :: Pred sym        -- ^ Is the value safe/defined?+    , _extra      :: Maybe Text      -- ^ Additional human-readable context+    }+  deriving (Generic, Typeable)++-- -----------------------------------------------------------------------+-- ** Constructors++-- We expose these rather than the constructors to retain the freedom to+-- change the internal representation.++undefinedBehavior' :: UB.UndefinedBehavior (RegValue' sym)+                   -> Pred sym+                   -> Text+                   -> LLVMSafetyAssertion sym+undefinedBehavior' ub pred expl =+  LLVMSafetyAssertion (BBUndefinedBehavior ub) pred (Just expl)++undefinedBehavior :: UB.UndefinedBehavior (RegValue' sym)+                  -> Pred sym+                  -> LLVMSafetyAssertion sym+undefinedBehavior ub pred =+  LLVMSafetyAssertion (BBUndefinedBehavior ub) pred Nothing++memoryError :: (1 <= w) => ME.MemoryOp sym w -> ME.MemoryErrorReason -> Pred sym -> LLVMSafetyAssertion sym+memoryError mop rsn pred =+  LLVMSafetyAssertion (BBMemoryError (ME.MemoryError mop rsn)) pred Nothing++poison' :: Poison.Poison (RegValue' sym)+        -> Pred sym+        -> Text+        -> LLVMSafetyAssertion sym+poison' poison_ pred expl =+  LLVMSafetyAssertion (BBUndefinedBehavior (UB.PoisonValueCreated poison_)) pred (Just expl)++poison :: Poison.Poison (RegValue' sym)+       -> Pred sym+       -> LLVMSafetyAssertion sym+poison poison_ pred =+  LLVMSafetyAssertion (BBUndefinedBehavior (UB.PoisonValueCreated poison_)) pred Nothing++-- -----------------------------------------------------------------------+-- ** Lenses++classifier :: Simple Lens (LLVMSafetyAssertion sym) (BadBehavior sym)+classifier = lens _classifier (\s v -> s { _classifier = v})++predicate :: Simple Lens (LLVMSafetyAssertion sym) (Pred sym)+predicate = lens _predicate (\s v -> s { _predicate = v})++extra :: Simple Lens (LLVMSafetyAssertion sym) (Maybe Text)+extra = lens _extra (\s v -> s { _extra = v})++explainBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann+explainBB = \case+  BBUndefinedBehavior ub -> UB.explain ub+  BBMemoryError me       -> ME.explain me++detailBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann+detailBB = \case+  BBUndefinedBehavior ub -> UB.ppDetails ub+  BBMemoryError me -> ME.details me++ppBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann+ppBB = \case+  BBUndefinedBehavior ub -> UB.ppDetails ub+  BBMemoryError me -> ME.ppMemoryError me
+ src/Lang/Crucible/LLVM/Errors/MemoryError.hs view
@@ -0,0 +1,260 @@+-- |+-- Module           : Lang.Crucible.LLVM.Errors.MemoryError+-- Description      : Errors that arise when reading and writing memory+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Langston Barrett <lbarrett@galois.com>+-- Stability        : provisional+--+--------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+module Lang.Crucible.LLVM.Errors.MemoryError+( MemoryError(..)+, MemErrContext+, explain+, details+, ppMemoryError+, MemoryOp(..)+, memOpMem+, ppMemoryOp+, MemoryErrorReason(..)+, ppMemoryErrorReason+, FuncLookupError(..)+, ppFuncLookupError++, concMemoryError+, concMemoryOp+) where++import           Prelude hiding (pred)++import           Data.Text (Text)+import qualified Text.LLVM.AST as L+import           Type.Reflection (SomeTypeRep(SomeTypeRep))+import           Prettyprinter++import           What4.Interface+import           What4.Expr (GroundValue)++import           Lang.Crucible.LLVM.MemModel.Pointer (LLVMPtr, concBV)+import           Lang.Crucible.LLVM.MemModel.Common+import           Lang.Crucible.LLVM.MemModel.Type+import           Lang.Crucible.LLVM.MemModel.MemLog+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP++data MemoryOp sym w+  = MemLoadOp  StorageType (Maybe String) (LLVMPtr sym w) (Mem sym)+  | MemStoreOp StorageType (Maybe String) (LLVMPtr sym w) (Mem sym)+  | MemStoreBytesOp (Maybe String) (LLVMPtr sym w) (Maybe (SymBV sym w)) (Mem sym)+  | forall wlen. (1 <= wlen) => MemCopyOp+       (Maybe String, LLVMPtr sym w) -- dest+       (Maybe String, LLVMPtr sym w) -- src+       (SymBV sym wlen) -- length+       (Mem sym)+  | MemLoadHandleOp (Maybe L.Type) (Maybe String) (LLVMPtr sym w) (Mem sym)+  | forall wlen. (1 <= wlen) => MemInvalidateOp+       Text (Maybe String) (LLVMPtr sym w) (SymBV sym wlen) (Mem sym)++memOpMem :: MemoryOp sym w -> Mem sym+memOpMem =+  \case+    MemLoadOp _ _ _ mem -> mem+    MemStoreOp _ _ _ mem -> mem+    MemStoreBytesOp _ _ _ mem -> mem+    MemCopyOp _ _ _ mem -> mem+    MemLoadHandleOp _ _ _ mem -> mem+    MemInvalidateOp _ _ _ _ mem -> mem++data MemoryError sym where+  MemoryError :: (1 <= w) =>+    MemoryOp sym w ->+    MemoryErrorReason ->+    MemoryError sym++-- | The kinds of type errors that arise while reading memory/constructing LLVM+-- values+data MemoryErrorReason =+    TypeMismatch StorageType StorageType+  | UnexpectedArgumentType Text [StorageType]+  | ApplyViewFail ValueView+  | Invalid StorageType+  | Invalidated Text+  | NoSatisfyingWrite StorageType+  | UnwritableRegion+  | UnreadableRegion+  | BadFunctionPointer FuncLookupError+  | OverlappingRegions+  deriving (Eq, Ord)++-- | Reasons that looking up a function handle associated with an LLVM pointer+-- may fail+data FuncLookupError+  = SymbolicPointer+  | RawBitvector+  | NoOverride+  | Uncallable SomeTypeRep+  deriving (Eq, Ord)++ppFuncLookupError :: FuncLookupError -> Doc ann+ppFuncLookupError =+  \case+    SymbolicPointer -> "Cannot resolve a symbolic pointer to a function handle"+    RawBitvector -> "Cannot treat raw bitvector as function pointer"+    NoOverride -> "No implementation or override found for pointer"+    Uncallable (SomeTypeRep typeRep) ->+      vsep [ "Data associated with the pointer found, but was not a callable function:"+           , hang 2 (viaShow typeRep)+           ]++type MemErrContext sym w = MemoryOp sym w++ppGSym :: Maybe String -> [Doc ann]+ppGSym Nothing = []+ppGSym (Just nm) = [ "Global symbol", viaShow nm ]++ppMemoryOp :: IsExpr (SymExpr sym) => MemoryOp sym w -> Doc ann+ppMemoryOp (MemLoadOp tp gsym ptr mem)  =+  vsep [ "Performing overall load at type:" <+> ppType tp+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemStoreOp tp gsym ptr mem) =+  vsep [ "Performing store at type:" <+> ppType tp+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemStoreBytesOp gsym ptr Nothing mem) =+  vsep [ "Performing byte array store for entire address space"+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemStoreBytesOp gsym ptr (Just len) mem) =+  vsep [ "Performing byte array store of length:" <+> printSymExpr len+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemCopyOp (gsym_dest, dest) (gsym_src, src) len mem) =+  vsep [ "Performing a memory copy of" <+> printSymExpr len <+> "bytes"+       , indent 2 (hsep ([ "Destination:" ] ++ ppGSym gsym_dest ++ [ ppPtr dest ]))+       , indent 2 (hsep ([ "Source:     " ] ++ ppGSym gsym_src ++ [ ppPtr src ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemLoadHandleOp sig gsym ptr mem) =+  vsep [ case sig of+           Just s ->+             hsep ["Attempting to load callable function with type:", viaShow (LPP.ppType s)]+           Nothing ->+             hsep ["Attempting to load callable function:"]+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++ppMemoryOp (MemInvalidateOp msg gsym ptr len mem) =+  vsep [ "Performing explicit memory invalidation of" <+> printSymExpr len <+> "bytes"+       , pretty msg+       , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ]))+       , "In memory state:"+       , indent 2 (ppMem mem)+       ]++explain :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann+explain (MemoryError _mop rsn) = ppMemoryErrorReason rsn++details :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann+details (MemoryError mop _rsn) = ppMemoryOp mop++ppMemoryError :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann+ppMemoryError (MemoryError mop rsn) = vcat [ppMemoryErrorReason rsn, ppMemoryOp mop]++ppMemoryErrorReason :: MemoryErrorReason -> Doc ann+ppMemoryErrorReason =+  \case+    TypeMismatch ty1 ty2 ->+      vcat+      [ "Type mismatch: "+      , indent 2 (vcat [ ppType ty1+                       , ppType ty2+                       ])+      ]+    UnexpectedArgumentType txt vals ->+      vcat+      [ "Unexpected argument type:"+      , pretty txt+      , indent 2 (vcat (map viaShow vals))+      ]+    ApplyViewFail vw ->+      "Failure when applying value view" <+> viaShow vw+    Invalid ty ->+      "Load from invalid memory at type" <+> ppType ty+    Invalidated msg ->+      "Load from explicitly invalidated memory:" <+> pretty msg+    NoSatisfyingWrite tp ->+      vcat+       [ "No previous write to this location was found"+       , indent 2 ("Attempting load at type:" <+> ppType tp)+       ]+    UnwritableRegion ->+      "The region wasn't allocated, wasn't large enough, or was marked as readonly"+    UnreadableRegion ->+      "The region wasn't allocated or wasn't large enough"+    BadFunctionPointer err ->+      vcat+       [ "The given pointer could not be resolved to a callable function"+       , ppFuncLookupError err+       ]+    OverlappingRegions ->+      "Memory regions required to be disjoint"++concMemoryError ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemoryError sym -> IO (MemoryError sym)+concMemoryError sym conc (MemoryError mop rsn) =+  MemoryError <$> concMemoryOp sym conc mop <*> pure rsn++concMemoryOp ::+  (1 <= w, IsExprBuilder sym) =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemoryOp sym w -> IO (MemoryOp sym w)+concMemoryOp sym conc (MemLoadOp tp gsym ptr mem) =+  MemLoadOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem+concMemoryOp sym conc (MemStoreOp tp gsym ptr mem) =+  MemStoreOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem+concMemoryOp sym conc (MemStoreBytesOp gsym ptr len mem) =+  MemStoreBytesOp gsym <$>+    concPtr sym conc ptr <*>+    traverse (concBV sym conc) len <*>+    concMem sym conc mem+concMemoryOp sym conc (MemLoadHandleOp tp gsym ptr mem) =+  MemLoadHandleOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem+concMemoryOp sym conc (MemCopyOp (gsym_dest, dest) (gsym_src, src) len mem) =+  do dest' <- concPtr sym conc dest+     src'  <- concPtr sym conc src+     len'  <- concBV sym conc len+     mem'  <- concMem sym conc mem+     pure (MemCopyOp (gsym_dest, dest') (gsym_src, src') len' mem')+concMemoryOp sym conc (MemInvalidateOp msg gsym ptr len mem) =+  MemInvalidateOp msg gsym <$>+    concPtr sym conc ptr <*>+    concBV sym conc len <*>+    concMem sym conc mem
+ src/Lang/Crucible/LLVM/Errors/Poison.hs view
@@ -0,0 +1,398 @@+-- |+-- Module           : Lang.Crucible.LLVM.Errors.Poison+-- Description      : All about LLVM poison values+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Langston Barrett <lbarrett@galois.com>+-- Stability        : provisional+--+-- This module is intended to be imported qualified.+--+-- Undefined values follow control flow, wereas the poison values follow data+-- flow. See the module-level comment in "Lang.Crucible.LLVM.Translation".+--+-- This email provides an explanation and motivation for poison and @undef@+-- values: https://lists.llvm.org/pipermail/llvm-dev/2016-October/106182.html+--------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM.Errors.Poison+  ( Poison(..)+  , cite+  , explain+  , standard+  , details+  , pp+  , ppReg+  , concPoison+  ) where++import           Data.Kind (Type)+import           Data.Maybe (isJust)+import           Data.Typeable (Typeable)+import           Prettyprinter++import qualified Data.Parameterized.TraversableF as TF+import           Data.Parameterized.TraversableF (FunctorF(..), FoldableF(..), TraversableF(..))+import qualified Data.Parameterized.TH.GADT as U+import           Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..))+import           Data.Parameterized.Classes (OrderingF(..), toOrdering)++import           Lang.Crucible.LLVM.Errors.Standards+import           Lang.Crucible.LLVM.MemModel.Pointer (LLVMPointerType, concBV, concPtr', ppPtr)+import           Lang.Crucible.Simulator.RegValue (RegValue'(..))+import           Lang.Crucible.Types+import qualified What4.Interface as W4I+import           What4.Expr (GroundValue)++data Poison (e :: CrucibleType -> Type) where+  -- | Arguments: @op1@, @op2@+  AddNoUnsignedWrap   :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  AddNoSignedWrap     :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  SubNoUnsignedWrap   :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  SubNoSignedWrap     :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  MulNoUnsignedWrap   :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  MulNoSignedWrap     :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  UDivExact           :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  SDivExact           :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  ShlOp2Big           :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  ShlNoUnsignedWrap   :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  ShlNoSignedWrap     :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  LshrExact           :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  LshrOp2Big          :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  AshrExact           :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | Arguments: @op1@, @op2@+  AshrOp2Big          :: (1 <= w) => e (BVType w)+                      -> e (BVType w)+                      -> Poison e+  -- | TODO(langston): store the 'Vector'+  ExtractElementIndex :: (1 <= w) => e (BVType w)+                      -> Poison e+  -- | TODO(langston): store the 'Vector'+  InsertElementIndex  :: (1 <= w) => e (BVType w)+                      -> Poison e+  LLVMAbsIntMin       :: (1 <= w) => e (BVType w)+                      -> Poison e+  GEPOutOfBounds      :: (1 <= w, 1 <= wptr) => e (LLVMPointerType wptr)+                      -> e (BVType w)+                      -> Poison e+  deriving (Typeable)++standard :: Poison e -> Standard+standard =+  \case+    AddNoUnsignedWrap _ _   -> LLVMRef LLVM8+    AddNoSignedWrap _ _     -> LLVMRef LLVM8+    SubNoUnsignedWrap _ _   -> LLVMRef LLVM8+    SubNoSignedWrap _ _     -> LLVMRef LLVM8+    MulNoUnsignedWrap _ _   -> LLVMRef LLVM8+    MulNoSignedWrap _ _     -> LLVMRef LLVM8+    UDivExact _ _           -> LLVMRef LLVM8+    SDivExact _ _           -> LLVMRef LLVM8+    ShlOp2Big _ _           -> LLVMRef LLVM8+    ShlNoUnsignedWrap _ _   -> LLVMRef LLVM8+    ShlNoSignedWrap _ _     -> LLVMRef LLVM8+    LshrExact _ _           -> LLVMRef LLVM8+    LshrOp2Big _ _          -> LLVMRef LLVM8+    AshrExact _ _           -> LLVMRef LLVM8+    AshrOp2Big _ _          -> LLVMRef LLVM8+    ExtractElementIndex _   -> LLVMRef LLVM8+    InsertElementIndex _    -> LLVMRef LLVM8+    LLVMAbsIntMin _         -> LLVMRef LLVM12+    GEPOutOfBounds _ _      -> LLVMRef LLVM8++-- | Which section(s) of the document state that this is poison?+cite :: Poison e -> Doc ann+cite =+  \case+    AddNoUnsignedWrap _ _   -> "‘add’ Instruction (Semantics)"+    AddNoSignedWrap _ _     -> "‘add’ Instruction (Semantics)"+    SubNoUnsignedWrap _ _   -> "‘sub’ Instruction (Semantics)"+    SubNoSignedWrap _ _     -> "‘sub’ Instruction (Semantics)"+    MulNoUnsignedWrap _ _   -> "‘mul’ Instruction (Semantics)"+    MulNoSignedWrap _ _     -> "‘mul’ Instruction (Semantics)"+    UDivExact _ _           -> "‘udiv’ Instruction (Semantics)"+    SDivExact _ _           -> "‘sdiv’ Instruction (Semantics)"+    ShlOp2Big _ _           -> "‘shl’ Instruction (Semantics)"+    ShlNoUnsignedWrap _ _   -> "‘shl’ Instruction (Semantics)"+    ShlNoSignedWrap _ _     -> "‘shl’ Instruction (Semantics)"+    LshrExact _ _           -> "‘lshr’ Instruction (Semantics)"+    LshrOp2Big _ _          -> "‘lshr’ Instruction (Semantics)"+    AshrExact _ _           -> "‘ashr’ Instruction (Semantics)"+    AshrOp2Big _ _          -> "‘ashr’ Instruction (Semantics)"+    ExtractElementIndex _   -> "‘extractelement’ Instruction (Semantics)"+    InsertElementIndex _    -> "‘insertelement’ Instruction (Semantics)"+    LLVMAbsIntMin _         -> "‘llvm.abs.*’ Intrinsic (Semantics)"+    GEPOutOfBounds _ _      -> "‘getelementptr’ Instruction (Semantics)"++explain :: Poison e -> Doc ann+explain =+  \case+    AddNoUnsignedWrap _ _ ->+      "Unsigned addition caused wrapping even though the `nuw` flag was set"+    AddNoSignedWrap _ _ ->+      "Signed addition caused wrapping even though the `nsw` flag was set"+    SubNoUnsignedWrap _ _ ->+      "Unsigned subtraction caused wrapping even though the `nuw` flag was set"+    SubNoSignedWrap _ _  ->+      "Signed subtraction caused wrapping even though the `nsw` flag was set"+    MulNoUnsignedWrap _ _ ->+      "Unsigned multiplication caused wrapping even though the `nuw` flag was set"+    MulNoSignedWrap _ _ ->+      "Signed multiplication caused wrapping even though the `nsw` flag was set"+    SDivExact _ _ ->+      "Inexact signed division even though the `exact` flag was set"+    UDivExact _ _ ->+      "Inexact unsigned division even though the `exact` flag was set"+    ShlOp2Big _ _ ->+      "The second operand of `shl` was equal to or greater than the number of bits in the first operand"+    ShlNoUnsignedWrap _ _ ->+      "Left shift shifted out non-zero bits even though the `nuw` flag was set"+    ShlNoSignedWrap _ _ ->+      "Left shift shifted out some bits that disagreed with the sign bit even though the `nsw` flag was set"+    LshrExact _ _ ->+      "Inexact `lshr` (logical right shift) result even though the `exact` flag was set"+    LshrOp2Big _ _ ->+      "The second operand of `lshr` was equal to or greater than the number of bits in the first operand"+    AshrExact _ _ ->+      "Inexact `ashr` (arithmetic right shift) result even though the `exact` flag was set"+    AshrOp2Big _ _   ->+      "The second operand of `ashr` was equal to or greater than the number of bits in the first operand"+    ExtractElementIndex _   -> cat $+      [ "Attempted to extract an element from a vector at an index that was"+      , "greater than the length of the vector"+      ]+    InsertElementIndex _   -> cat $+      [ "Attempted to insert an element into a vector at an index that was"+      , "greater than the length of the vector"+      ]+    LLVMAbsIntMin _ -> cat $+      [ "The first argument of `llvm.abs.*` was `INT_MIN` even though the"+      , "second argument was `1`"+      ]++    -- The following explanation is a bit unsatisfactory, because it is specific+    -- to how we treat this instruction in Crucible.+    GEPOutOfBounds _ _ -> cat $+      [ "Calling `getelementptr` resulted in an index that was out of bounds for the"+      , "given allocation (likely due to arithmetic overflow), but Crucible currently"+      , "treats all GEP instructions as if they had the `inbounds` flag set."+      ]++details :: forall sym ann.+  W4I.IsExpr (W4I.SymExpr sym) => Poison (RegValue' sym) -> [Doc ann]+details =+  \case+    AddNoUnsignedWrap v1 v2 -> args [v1, v2]+    AddNoSignedWrap   v1 v2 -> args [v1, v2]+    SubNoUnsignedWrap v1 v2 -> args [v1, v2]+    SubNoSignedWrap   v1 v2 -> args [v1, v2]+    MulNoUnsignedWrap v1 v2 -> args [v1, v2]+    MulNoSignedWrap   v1 v2 -> args [v1, v2]+    SDivExact         v1 v2 -> args [v1, v2]+    UDivExact         v1 v2 -> args [v1, v2]+    ShlOp2Big         v1 v2 -> args [v1, v2]+    ShlNoUnsignedWrap v1 v2 -> args [v1, v2]+    ShlNoSignedWrap   v1 v2 -> args [v1, v2]+    LshrExact         v1 v2 -> args [v1, v2]+    LshrOp2Big        v1 v2 -> args [v1, v2]+    AshrExact         v1 v2 -> args [v1, v2]+    AshrOp2Big        v1 v2 -> args [v1, v2]+    ExtractElementIndex v   -> args [v]+    InsertElementIndex v    -> args [v]+    LLVMAbsIntMin v         -> args [v]+    GEPOutOfBounds (RV ptr) (RV bv) ->+      [ "Pointer:" <+> ppPtr ptr+      , "Bitvector:" <+> W4I.printSymExpr bv+      ]++ where+ args :: forall w. [RegValue' sym (BVType w)] -> [Doc ann]+ args []     = [ "No arguments" ]+ args [RV v] = [ "Argument:" <+> W4I.printSymExpr v ]+ args vs     = [ hsep ("Arguments:" : map (W4I.printSymExpr . unRV) vs) ]+++-- | Pretty print an error message relating to LLVM poison values,+--   when given a printer to produce a detailed message.+pp :: (Poison e -> [Doc ann]) -> Poison e -> Doc ann+pp extra poison = vcat $+  [ "Poison value encountered: "+  , explain poison+  , vcat (extra poison)+  , cat [ "Reference: "+        , pretty (ppStd (standard poison))+        , cite poison+        ]+  ] ++ case stdURL (standard poison) of+         Just url -> ["Document URL:" <+> pretty url]+         Nothing  -> []++-- | Pretty print an error message relating to LLVM poison values+ppReg ::W4I.IsExpr (W4I.SymExpr sym) => Poison (RegValue' sym) -> Doc ann+ppReg = pp details++-- | Concretize a poison error message.+concPoison :: forall sym.+  W4I.IsExprBuilder sym =>+  sym ->+  (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) ->+  Poison (RegValue' sym) -> IO (Poison (RegValue' sym))+concPoison sym conc poison =+  let bv :: forall w. (1 <= w) => RegValue' sym (BVType w) -> IO (RegValue' sym (BVType w))+      bv (RV x) = RV <$> concBV sym conc x in+  case poison of+    AddNoUnsignedWrap v1 v2 ->+      AddNoUnsignedWrap <$> bv v1 <*> bv v2+    AddNoSignedWrap v1 v2 ->+      AddNoSignedWrap <$> bv v1 <*> bv v2+    SubNoUnsignedWrap v1 v2 ->+      SubNoUnsignedWrap <$> bv v1 <*> bv v2+    SubNoSignedWrap v1 v2 ->+      SubNoSignedWrap <$> bv v1 <*> bv v2+    MulNoUnsignedWrap v1 v2 ->+      MulNoUnsignedWrap<$> bv v1 <*> bv v2+    MulNoSignedWrap v1 v2 ->+      MulNoSignedWrap <$> bv v1 <*> bv v2+    UDivExact v1 v2 ->+      UDivExact <$> bv v1 <*> bv v2+    SDivExact v1 v2 ->+      SDivExact <$> bv v1 <*> bv v2+    ShlOp2Big v1 v2 ->+      ShlOp2Big <$> bv v1 <*> bv v2+    ShlNoUnsignedWrap v1 v2 ->+      ShlNoUnsignedWrap <$> bv v1 <*> bv v2+    ShlNoSignedWrap v1 v2 ->+      ShlNoSignedWrap <$> bv v1 <*> bv v2+    LshrExact v1 v2 ->+      LshrExact <$> bv v1 <*> bv v2+    LshrOp2Big v1 v2 ->+      LshrOp2Big <$> bv v1 <*> bv v2+    AshrExact v1 v2 ->+      AshrExact <$> bv v1 <*> bv v2+    AshrOp2Big v1 v2 ->+      AshrOp2Big <$> bv v1 <*> bv v2+    ExtractElementIndex v ->+      ExtractElementIndex <$> bv v+    InsertElementIndex v ->+      InsertElementIndex <$> bv v+    GEPOutOfBounds p v ->+      GEPOutOfBounds <$> concPtr' sym conc p <*> bv v+    LLVMAbsIntMin v ->+      LLVMAbsIntMin <$> bv v+++-- -----------------------------------------------------------------------+-- ** Instances++-- The weirdness in these instances is due to existential quantification over+-- the width. We have to make sure the type variable doesn't escape its scope.++$(return [])++eqcPoison :: forall e.+  (forall t1 t2. e t1 -> e t2 -> Maybe (t1 :~: t2)) ->+  Poison e -> Poison e -> Maybe (() :~: ())+eqcPoison subterms =+  let subterms' :: forall p q. e p -> e q -> Maybe (() :~: ())+      subterms' a b =+         case subterms a b of+           Just Refl -> Just Refl+           Nothing   -> Nothing+   in $(U.structuralTypeEquality [t|Poison|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |])+       ])++ordcPoison :: forall e f.+  (forall t1 t2. e t1 -> f t2 -> OrderingF t1 t2) ->+  Poison e -> Poison f -> OrderingF () ()+ordcPoison subterms =+  let subterms' :: forall p q. e p -> f q -> OrderingF () ()+      subterms' a b =+         case subterms a b of+           EQF -> (EQF :: OrderingF () ())+           GTF -> (GTF :: OrderingF () ())+           LTF -> (LTF :: OrderingF () ())++   in $(U.structuralTypeOrd [t|Poison|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |])+       ])++instance TestEqualityC Poison where+  testEqualityC subterms x y = isJust $ eqcPoison subterms x y++instance OrdC Poison where+  compareC subterms x y = toOrdering $ ordcPoison subterms x y++instance FunctorF Poison where+  fmapF = TF.fmapFDefault++instance FoldableF Poison where+  foldMapF = TF.foldMapFDefault++instance TraversableF Poison where+  traverseF :: forall m e f. Applicative m+            => (forall s. e s -> m (f s))+            -> Poison e+            -> m (Poison f)+  traverseF =+    $(U.structuralTraversal [t|Poison|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType+         , [| ($) |] -- \f x -> f x+         )+       ]+     )
+ src/Lang/Crucible/LLVM/Errors/Standards.hs view
@@ -0,0 +1,100 @@+-- |+-- Module           : Lang.Crucible.LLVM.Errors.Standards+-- Description      : Standards documents+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Langston Barrett <lbarrett@galois.com>+-- Stability        : provisional+--+--------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE Safe #-}++module Lang.Crucible.LLVM.Errors.Standards+  ( Standard(..)+  , CStdVer(..)+  , CXXStdVer(..)+  , LLVMRefVer(..)+  , ppStd+  , stdURL+  ) where++import           Prelude hiding (unwords, unlines)++import           Data.Data (Data)+import           Data.Typeable (Typeable)+import           GHC.Generics (Generic)++import           Data.Text (Text, pack)++-- | The various standards that prohibit certain behaviors+data Standard =+    CStd    CStdVer    -- ^ The C language standard+  | CXXStd  CXXStdVer  -- ^ The C++ language standard+  | LLVMRef LLVMRefVer -- ^ The LLVM language reference+  deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++-- | Versions of the C standard+data CStdVer =+    C99+  | C11+  | C18+  deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++-- | Versions of the C++ standard+data CXXStdVer =+    CXX03+  | CXX11+  | CXX14+  | CXX17+  deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++ppCXXStdVer :: CXXStdVer -> Text+ppCXXStdVer CXX03 = "C++03"+ppCXXStdVer CXX11 = "C++11"+ppCXXStdVer CXX14 = "C++14"+ppCXXStdVer CXX17 = "C++17"++-- | Versions of the LLVM Language Reference+data LLVMRefVer =+    LLVM38+  | LLVM4+  | LLVM5+  | LLVM6+  | LLVM7+  | LLVM8+  | LLVM12+  deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++ppLLVMRefVer :: LLVMRefVer -> Text+ppLLVMRefVer LLVM38 = "3.8"+ppLLVMRefVer LLVM4  = "4"+ppLLVMRefVer LLVM5  = "5"+ppLLVMRefVer LLVM6  = "6"+ppLLVMRefVer LLVM7  = "7"+ppLLVMRefVer LLVM8  = "8"+ppLLVMRefVer LLVM12 = "12"++stdURL :: Standard -> Maybe Text+stdURL (CStd   C11)     = Just "http://www.iso-9899.info/n1570.html"+stdURL (CXXStd CXX17)   = Just "http://www.open-std.org/jtc1/sc22/wg14/www/abq/c17_updated_proposed_fdis.pdf"+stdURL (LLVMRef LLVM38) = Just "https://releases.llvm.org/3.8.0/docs/LangRef.html"+stdURL (LLVMRef LLVM4)  = Just "https://releases.llvm.org/4.0.1/docs/LangRef.html"+stdURL (LLVMRef LLVM5)  = Just "https://releases.llvm.org/5.0.0/docs/LangRef.html"+stdURL (LLVMRef LLVM6)  = Just "https://releases.llvm.org/6.0.0/docs/LangRef.html"+stdURL (LLVMRef LLVM7)  = Just "https://releases.llvm.org/7.0.0/docs/LangRef.html"+stdURL (LLVMRef LLVM8)  = Just "https://releases.llvm.org/8.0.0/docs/LangRef.html"+stdURL (LLVMRef LLVM12) = Just "https://releases.llvm.org/12.0.0/docs/LangRef.html"+stdURL _                = Nothing++ppStd :: Standard -> Text+ppStd =+  \case+    CStd    ver -> "The C language standard, version "     <> pack (show ver)+    CXXStd  ver -> "The C++ language standard, version "   <> ppCXXStdVer ver+    LLVMRef ver -> "The LLVM language reference, version " <> ppLLVMRefVer ver
+ src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs view
@@ -0,0 +1,615 @@+-- |+-- Module           : Lang.Crucible.LLVM.Errors.UndefinedBehavior+-- Description      : All about undefined behavior+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Langston Barrett <lbarrett@galois.com>+-- Stability        : provisional+--+-- This module is intended to be imported qualified.+--+-- This module serves as an ad-hoc reference for the sort of undefined behaviors+-- that the Crucible LLVM memory model is aware of. The information contained+-- here is used in+--  * providing helpful error messages+--  * configuring which safety checks to perform+--+-- Disabling checks for undefined behavior does not change the behavior of any+-- memory operations. If it is used to enable the simulation of undefined+-- behavior, the result is that any guarantees that Crucible provides about the+-- code essentially have an additional hypothesis: that the LLVM+-- compiler/hardware platform behave identically to Crucible's simulator when+-- encountering such behavior.+--------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM.Errors.UndefinedBehavior+  (+  -- ** Undefined Behavior+    PtrComparisonOperator(..)+  , UndefinedBehavior(..)+  , cite+  , details+  , explain+  , ppDetails+  , ppCitation+  , pp++  , concUB+  ) where++import           Prelude++import           GHC.Generics (Generic)+import           Data.Data (Data)+import           Data.Kind (Type)+import           Data.Maybe (isJust)+import           Data.Typeable (Typeable)+import           Prettyprinter++import           Data.Parameterized.Classes (toOrdering, fromOrdering)+import           Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..))+import qualified Data.Parameterized.TH.GADT as U+import           Data.Parameterized.TraversableF (FunctorF(..), FoldableF(..), TraversableF(..))+import qualified Data.Parameterized.TraversableF as TF++import qualified What4.Interface as W4I+import           What4.Expr (GroundValue)++import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.RegValue (RegValue'(..))+import           Lang.Crucible.LLVM.DataLayout (Alignment, fromAlignment)+import           Lang.Crucible.LLVM.Errors.Standards+import qualified Lang.Crucible.LLVM.Errors.Poison as Poison+import           Lang.Crucible.LLVM.MemModel.Pointer (ppPtr, concBV, concPtr')+import           Lang.Crucible.LLVM.MemModel.Type (StorageType)+import           Lang.Crucible.LLVM.Types (LLVMPointerType)++-- -----------------------------------------------------------------------+-- ** UndefinedBehavior++-- | The various comparison operators you can use on pointers+data PtrComparisonOperator =+    Eq+  | Leq+  deriving (Data, Eq, Generic, Enum, Ord, Read, Show)++ppPtrComparison :: PtrComparisonOperator -> Doc ann+ppPtrComparison Eq  = "Equality comparison (==)"+ppPtrComparison Leq = "Ordering comparison (<=)"++-- | This type is parameterized on a higher-kinded term constructor so that it+-- can be instantiated for expressions at translation time (i.e. the 'Expr' in+-- 'LLVMGenerator'), or for expressions at runtime ('SymExpr').+--+-- See 'cite' and 'explain' for what each constructor means at the C/LLVM level.+--+-- The commented-out constructors correspond to behaviors that don't have+-- explicit checks yet (but probably should!).+data UndefinedBehavior (e :: CrucibleType -> Type) where++  -- -------------------------------- Memory management++  FreeBadOffset ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  FreeUnallocated ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  DoubleFree ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  -- | Arguments: Destination pointer, fill byte, length+  MemsetInvalidRegion ::+    (1 <= w, 1 <= v) =>+    e (LLVMPointerType w) ->+    e (BVType 8) ->+    e (BVType v) ->+    UndefinedBehavior e++  -- | Arguments: Read destination, alignment+  ReadBadAlignment ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    Alignment ->+    UndefinedBehavior e++  -- | Arguments: Write destination, alignment+  WriteBadAlignment ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    Alignment ->+    UndefinedBehavior e++  -- -------------------------------- Pointer arithmetic++  PtrAddOffsetOutOfBounds ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    e (BVType w) ->+    UndefinedBehavior e++  -- | Arguments: kind of comparison, the invalid pointer, the other pointer+  CompareInvalidPointer ::+    (1 <= w) =>+    PtrComparisonOperator ->+    e (LLVMPointerType w) ->+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  -- | "In all other cases, the behavior is undefined"+  -- TODO: 'PtrComparisonOperator' argument?+  CompareDifferentAllocs ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  -- | "When two pointers are subtracted, both shall point to elements of the+  -- same array object"+  PtrSubDifferentAllocs ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    e (LLVMPointerType w) ->+    UndefinedBehavior e++  -- | Pointer cast to an integer type other than+  --   pointer width integers+  PointerIntCast ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    StorageType ->+    UndefinedBehavior e++  -- | Pointer used in an unsupported arithmetic or bitvector operation+  PointerUnsupportedOp ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    String ->+    UndefinedBehavior e++  -- | Pointer cast to a floating-point type+  PointerFloatCast ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    StorageType ->+    UndefinedBehavior e++  -- | "One of the following shall hold: [...] one operand is a pointer and the+  -- other is a null pointer constant."+  ComparePointerToBV ::+    (1 <= w) =>+    e (LLVMPointerType w) ->+    e (BVType w) ->+    UndefinedBehavior e++  -------------------------------- Division operators++  -- | @SymBV@ or @Expr _ _ (BVType w)@+  UDivByZero   :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e+  SDivByZero   :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e+  URemByZero   :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e+  SRemByZero   :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e+  SDivOverflow :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e+  SRemOverflow :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e++  -------------------------------- Integer arithmetic++  AbsIntMin    :: (1 <= w) => e (BVType w) -> UndefinedBehavior e++  PoisonValueCreated ::+    Poison.Poison e ->+    UndefinedBehavior e++  {-+  MemcpyDisjoint          :: UndefinedBehavior e+  DereferenceBadAlignment :: UndefinedBehavior e+  ModifiedStringLiteral   :: UndefinedBehavior e+  -}+  deriving (Typeable)++-- | Which document prohibits this behavior?+standard :: UndefinedBehavior e -> Standard+standard =+  \case++    -- -------------------------------- Memory management++    DoubleFree{}              -> CStd C11+    FreeBadOffset{}           -> CStd C11+    FreeUnallocated{}         -> CStd C11+    MemsetInvalidRegion{}     -> CStd C11+    ReadBadAlignment{}        -> CStd C11+    WriteBadAlignment{}       -> CStd C11++    -- -------------------------------- Pointer arithmetic++    PtrAddOffsetOutOfBounds{} -> CStd C11+    CompareInvalidPointer{}   -> CStd C11+    CompareDifferentAllocs{}  -> CStd C11+    PtrSubDifferentAllocs{}   -> CStd C11+    ComparePointerToBV{}      -> CStd C11+    PointerFloatCast{}        -> CStd C11+    PointerIntCast{}          -> CStd C11+    PointerUnsupportedOp{}    -> CStd C11++    -- -------------------------------- Division operators++    UDivByZero{}   -> CStd C11+    SDivByZero{}   -> CStd C11+    URemByZero{}   -> CStd C11+    SRemByZero{}   -> CStd C11+    SDivOverflow{} -> CStd C11+    SRemOverflow{} -> CStd C11++    -- -------------------------------- Integer arithmetic++    AbsIntMin{}    -> CStd C11++    PoisonValueCreated p -> Poison.standard p++    {-+    MemcpyDisjoint          -> CStd C11+    DereferenceBadAlignment -> CStd C11+    ModifiedStringLiteral   -> CStd C11+    -}++-- | Which section(s) of the document prohibit this behavior?+cite :: UndefinedBehavior e -> Doc ann+cite =+  \case++    -------------------------------- Memory management++    FreeBadOffset{}           -> "§7.22.3.3 The free function, ¶2"+    FreeUnallocated{}         -> "§7.22.3.3 The free function, ¶2"+    DoubleFree{}              -> "§7.22.3.3 The free function, ¶2"+    MemsetInvalidRegion{}     -> "§7.24.1 String function conventions, ¶1"+    ReadBadAlignment{}        -> "§6.5.3.2 Address and indirection operators, ¶4"+    WriteBadAlignment{}       -> "§6.5.3.2 Address and indirection operators, ¶4"++    ---------------------------------- Pointer arithmetic++    PtrAddOffsetOutOfBounds{} -> "§6.5.6 Additive operators, ¶8"+    CompareInvalidPointer{}   -> "§6.5.8 Relational operators, ¶5"+    CompareDifferentAllocs{}  -> "§6.5.8 Relational operators, ¶5"+    PtrSubDifferentAllocs{}   -> "§6.5.6 Additive operators, ¶9"+    ComparePointerToBV{}      -> "§6.5.9 Equality operators, ¶2"+    PointerFloatCast{}        -> "§6.5.4 Cast operators, ¶4"+    PointerIntCast{}          -> "§6.3.2.3 Conversions, pointers, ¶6"+    PointerUnsupportedOp{}    -> "§6.3.2.3 Conversions, pointers, ¶6"++    -------------------------------- Division operators++    UDivByZero{}   -> "§6.5.5 Multiplicitive operators, ¶5"+    SDivByZero{}   -> "§6.5.5 Multiplicitive operators, ¶5"+    URemByZero{}   -> "§6.5.5 Multiplicitive operators, ¶5"+    SRemByZero{}   -> "§6.5.5 Multiplicitive operators, ¶5"+    SDivOverflow{} -> "§6.5.5 Multiplicitive operators, ¶6"+    SRemOverflow{} -> "§6.5.5 Multiplicitive operators, ¶6"++    -------------------------------- Integer arithmetic++    AbsIntMin{} -> "§7.22.6 Integer arithmetic functions, ¶1"++    PoisonValueCreated p -> Poison.cite p++    -------------------------------- Other++    {-+    MemcpyDisjoint          -> "§7.24.2.1 The memcpy function"+    DereferenceBadAlignment -> "§6.5.3.2 Address and indirection operators"+    ModifiedStringLiteral   -> "§J.2 Undefined behavior" -- 6.4.5+    -}++-- | What happened, and why is it a problem?+--+-- This is a generic explanation that doesn't use the included data.+explain :: UndefinedBehavior e -> Doc ann+explain =+  \case++    -- -------------------------------- Memory management++    FreeBadOffset _ -> cat $+      [ "`free` called on pointer that was not previously returned by `malloc`"+      , "`calloc`, or another memory management function (the pointer did not"+      , "point to the base of an allocation, its offset should be 0)"+      ]+    FreeUnallocated _ ->+      "`free` called on pointer that didn't point to a live region of the heap"+    DoubleFree{} -> "`free` called on a pointer to already-freed memory"+    MemsetInvalidRegion{} ->+      "Pointer passed to `memset` didn't point to a mutable allocation with enough space"+    WriteBadAlignment _ _ ->+      "Wrote a value into a pointer with insufficent alignment"+    ReadBadAlignment _ _ ->+      "Read a value from a pointer with insufficent alignment"++    -- -------------------------------- Pointer arithmetic++    PtrAddOffsetOutOfBounds _ _ ->+      "Addition of an offset to a pointer resulted in a pointer to an address outside of the allocation"+    CompareInvalidPointer{} ->+      "Comparison of a pointer which wasn't null or a pointer to a live heap object"+    CompareDifferentAllocs _ _ ->+      "Comparison of pointers from different allocations"+    PtrSubDifferentAllocs _ _ ->+      "Subtraction of pointers from different allocations"+    ComparePointerToBV _ _ ->+      "Comparison of a pointer to a non zero (null) integer value"+    PointerFloatCast{} ->+      "Cast of a pointer to a floating-point type"+    PointerIntCast{} ->+      "Cast of a pointer to an incompatible integer type"+    PointerUnsupportedOp{} ->+      "Pointer cast to an integer used in an unsupported operation"++    -------------------------------- Division operators++    UDivByZero{}   -> "Unsigned division by zero"+    SDivByZero{}   -> "Signed division by zero"+    URemByZero{}   -> "Unsigned division by zero via remainder"+    SRemByZero{}   -> "Signed division by zero via remainder"+    SDivOverflow{} -> "Overflow during signed division"+    SRemOverflow{} -> "Overflow during signed division (via signed remainder)"++    -------------------------------- Integer arithmetic++    AbsIntMin{} -> "`abs`, `labs`, or `llabs` called on `INT_MIN`"++    PoisonValueCreated p -> vcat [ "Poison value created", Poison.explain p ]++    -------------------------------- Other++    {-+    MemcpyDisjoint     -> "Use of `memcpy` with non-disjoint regions of memory"+    DereferenceBadAlignment ->+      "Dereferenced a pointer to a type with the wrong alignment"+    ModifiedStringLiteral -> "Modified the underlying array of a string literal"+    -}++-- | Pretty-print the additional information held by the constructors+-- (for symbolic expressions)+details :: W4I.IsExpr (W4I.SymExpr sym)+        => UndefinedBehavior (RegValue' sym)+        -> [Doc ann]+details =+  \case++    -------------------------------- Memory management++    FreeBadOffset ptr   -> [ ppPtr1 ptr ]+    FreeUnallocated ptr -> [ ppPtr1 ptr ]+    DoubleFree ptr -> [ ppPtr1 ptr ]+    MemsetInvalidRegion destPtr fillByte len ->+      [ "Destination pointer:" <+> ppPtr1 destPtr+      , "Fill byte:          " <+> (W4I.printSymExpr $ unRV fillByte)+      , "Length:             " <+> (W4I.printSymExpr $ unRV len)+      ]+    WriteBadAlignment ptr alignment ->+      -- TODO: replace viaShow when we have instance Pretty Bytes+      [ "Required alignment:" <+> viaShow (fromAlignment alignment) <+> "bytes"+      , ppPtr1 ptr+      ]+    ReadBadAlignment ptr alignment ->+      -- TODO: replace viaShow when we have instance Pretty Bytes+      [ "Required alignment:" <+> viaShow (fromAlignment alignment) <+> "bytes"+      , ppPtr1 ptr+      ]++    -------------------------------- Pointer arithmetic++    PtrAddOffsetOutOfBounds ptr offset ->+      [ ppPtr1 ptr+      , ppOffset (unRV offset)+      ]+    CompareInvalidPointer comparison invalid other ->+      [ "Comparison:                    " <+> ppPtrComparison comparison+      , "Invalid pointer:               " <+> ppPtr (unRV invalid)+      , "Other (possibly valid) pointer:" <+> ppPtr (unRV other)+      ]+    CompareDifferentAllocs ptr1 ptr2 -> [ ppPtr2 ptr1 ptr2 ]+    PtrSubDifferentAllocs ptr1 ptr2  -> [ ppPtr2 ptr1 ptr2 ]+    ComparePointerToBV ptr bv ->+      [ ppPtr1 ptr+      , "Bitvector:" <+> (W4I.printSymExpr $ unRV bv)+      ]+    PointerFloatCast ptr castType ->+      [ ppPtr1 ptr+      , "Cast to:" <+> viaShow castType+      ]+    PointerIntCast ptr castType ->+      [ ppPtr1 ptr+      , "Cast to:" <+> viaShow castType+      ]+    PointerUnsupportedOp ptr msg ->+      [ ppPtr1 ptr+      , pretty msg+      ]++    -------------------------------- Division operators++    -- The cases are manually listed to prevent unintentional fallthrough if a+    -- constructor is added.+    UDivByZero v1 v2   -> [ ppBV2 v1 v2 ]+    SDivByZero v1 v2   -> [ ppBV2 v1 v2 ]+    URemByZero v1 v2   -> [ ppBV2 v1 v2 ]+    SRemByZero v1 v2   -> [ ppBV2 v1 v2 ]+    SDivOverflow v1 v2 -> [ ppBV2 v1 v2 ]+    SRemOverflow v1 v2 -> [ ppBV2 v1 v2 ]++    -------------------------------- Integer arithmetic++    AbsIntMin v -> [ ppBV1 v ]++    PoisonValueCreated p -> Poison.details p++  where ppBV1 :: W4I.IsExpr (W4I.SymExpr sym) =>+                 RegValue' sym (BVType w) -> Doc ann+        ppBV1 (RV bv) = "op:" <+> W4I.printSymExpr bv++        ppBV2 :: W4I.IsExpr (W4I.SymExpr sym) =>+                 RegValue' sym (BVType w) -> RegValue' sym (BVType w) -> Doc ann+        ppBV2 (RV bv1) (RV bv2) =+          vcat [ "op1: " <+> W4I.printSymExpr bv1+               , "op2: " <+> W4I.printSymExpr bv2+               ]++        ppPtr1 :: W4I.IsExpr (W4I.SymExpr sym) => RegValue' sym (LLVMPointerType w) -> Doc ann+        ppPtr1 (RV p) = "Pointer:" <+> ppPtr p++        ppPtr2 (RV ptr1) (RV ptr2) =+          vcat [ "Pointer 1:" <+>  ppPtr ptr1+               , "Pointer 2:" <+>  ppPtr ptr2+               ]++        ppOffset :: W4I.IsExpr e => e (BaseBVType w) -> Doc ann+        ppOffset = ("Offset:" <+>) . W4I.printSymExpr++pp :: (UndefinedBehavior e -> [Doc ann]) -- ^ Printer for constructor data+   -> UndefinedBehavior e+   -> Doc ann+pp extra ub = vcat (explain ub : extra ub ++ ppCitation ub)++-- | Pretty-printer for symbolic backends+ppDetails ::+  W4I.IsExpr (W4I.SymExpr sym) =>+  UndefinedBehavior (RegValue' sym) ->+  Doc ann+ppDetails ub = vcat (details ub ++ ppCitation ub)++ppCitation :: UndefinedBehavior e -> [Doc ann]+ppCitation ub =+   (cat [ "Reference: "+        , indent 2 (pretty (ppStd (standard ub)))+        , indent 2 (cite ub)+        ]+    : case stdURL (standard ub) of+        Just url -> [ indent 2 ("Document URL:" <+> pretty url) ]+        Nothing  -> [])++-- -----------------------------------------------------------------------+-- ** Instances++$(return [])++instance TestEqualityC UndefinedBehavior where+  testEqualityC subterms x y = isJust $+    $(U.structuralTypeEquality [t|UndefinedBehavior|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType+         , [| subterms |]+         )+       , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType+         , [| \a b -> if testEqualityC subterms a b then Just Refl else Nothing |]+         )+       ]+     ) x y++instance OrdC UndefinedBehavior where+  compareC subterms ub1 ub2 = toOrdering $+    $(U.structuralTypeOrd [t|UndefinedBehavior|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType+         , [| subterms |]+         )+       , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType+         , [| \a b -> fromOrdering (compareC subterms a b) |]+         )+       ]+     ) ub1 ub2++instance FunctorF UndefinedBehavior where+  fmapF = TF.fmapFDefault++instance FoldableF UndefinedBehavior where+  foldMapF = TF.foldMapFDefault++instance TraversableF UndefinedBehavior where+  traverseF subterms =+    $(U.structuralTraversal [t|UndefinedBehavior|]+       [ ( U.DataArg 0 `U.TypeApp` U.AnyType+         , [| \_ x -> subterms x |]+         )+       , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType+         , [| \_ x -> traverseF subterms x |]+         )+       ]+     ) subterms+++concUB :: forall sym.+  W4I.IsExprBuilder sym =>+  sym ->+  (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) ->+  UndefinedBehavior (RegValue' sym) -> IO (UndefinedBehavior (RegValue' sym))+concUB sym conc ub =+  let bv :: forall w. (1 <= w) => RegValue' sym (BVType w) -> IO (RegValue' sym (BVType w))+      bv (RV x) = RV <$> concBV sym conc x in+  case ub of+    FreeBadOffset ptr ->+      FreeBadOffset <$> concPtr' sym conc ptr+    FreeUnallocated ptr ->+      FreeUnallocated <$> concPtr' sym conc ptr+    DoubleFree ptr ->+      DoubleFree <$> concPtr' sym conc ptr+    MemsetInvalidRegion ptr val len ->+      MemsetInvalidRegion <$> concPtr' sym conc ptr <*> bv val <*> bv len+    ReadBadAlignment ptr a ->+      ReadBadAlignment <$> concPtr' sym conc ptr <*> pure a+    WriteBadAlignment ptr a ->+      WriteBadAlignment <$> concPtr' sym conc ptr <*> pure a++    PtrAddOffsetOutOfBounds ptr off ->+      PtrAddOffsetOutOfBounds <$> concPtr' sym conc ptr <*> bv off+    CompareInvalidPointer op p1 p2 ->+      CompareInvalidPointer op <$> concPtr' sym conc p1 <*> concPtr' sym conc p2+    CompareDifferentAllocs p1 p2 ->+      CompareDifferentAllocs <$> concPtr' sym conc p1 <*> concPtr' sym conc p2+    PtrSubDifferentAllocs p1 p2 ->+      PtrSubDifferentAllocs <$> concPtr' sym conc p1 <*> concPtr' sym conc p2+    PointerFloatCast ptr tp ->+      PointerFloatCast <$> concPtr' sym conc ptr <*> pure tp+    PointerIntCast ptr tp ->+      PointerIntCast <$> concPtr' sym conc ptr <*> pure tp+    PointerUnsupportedOp ptr msg ->+      PointerUnsupportedOp <$> concPtr' sym conc ptr <*> pure msg+    ComparePointerToBV ptr val ->+      ComparePointerToBV <$> concPtr' sym conc ptr <*> bv val+    UDivByZero v1 v2 ->+      UDivByZero <$> bv v1 <*> bv v2+    SDivByZero v1 v2 ->+      SDivByZero <$> bv v1 <*> bv v2+    URemByZero v1 v2 ->+      URemByZero <$> bv v1 <*> bv v2+    SRemByZero v1 v2 ->+      SRemByZero <$> bv v1 <*> bv v2+    SDivOverflow v1 v2 ->+      SDivOverflow <$> bv v1 <*> bv v2+    SRemOverflow v1 v2 ->+      SRemOverflow <$> bv v1 <*> bv v2+    AbsIntMin v ->+      AbsIntMin <$> bv v++    PoisonValueCreated poison ->+      PoisonValueCreated <$> Poison.concPoison sym conc poison
+ src/Lang/Crucible/LLVM/Eval.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Lang.Crucible.LLVM.Eval+  ( llvmExtensionEval+  , callStackFromMemVar+  ) where++import           Control.Lens ((^.), view)+import           Control.Monad (forM_)+import qualified Data.List.NonEmpty as NE+import           Data.Parameterized.TraversableF++import           What4.Interface++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common (GlobalVar)+import           Lang.Crucible.Simulator.ExecutionTree (SimState, CrucibleState)+import           Lang.Crucible.Simulator.ExecutionTree (stateGlobals)+import           Lang.Crucible.Simulator.GlobalState (lookupGlobal)+import           Lang.Crucible.Simulator.Intrinsics+import           Lang.Crucible.Simulator.Evaluation+import           Lang.Crucible.Simulator.RegValue+import           Lang.Crucible.Simulator.SimError+import           Lang.Crucible.Panic (panic)++import qualified Lang.Crucible.LLVM.Arch.X86 as X86+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.MemModel (memImplHeap)+import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack)+import           Lang.Crucible.LLVM.MemModel.MemLog (memState)+import           Lang.Crucible.LLVM.MemModel.Partial+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.Types (Mem)++callStackFromMemVar ::+  SimState p sym ext rtp lang args ->+  GlobalVar Mem ->+  CallStack+callStackFromMemVar state mvar =+  getCallStack . view memState . memImplHeap $+     case lookupGlobal mvar (state ^. stateGlobals) of+       Just v -> v+       Nothing ->+         panic "callStackFromMemVar"+           [ "Global heap value not initialized."+           , "*** Global heap variable: " ++ show mvar+           ]++assertSideCondition ::+  (HasLLVMAnn sym, IsSymBackend sym bak) =>+  bak ->+  CallStack ->+  LLVMSideCondition (RegValue' sym) ->+  IO ()+assertSideCondition bak callStack (LLVMSideCondition (RV p) ub) =+  do let sym = backendGetSym bak+     p' <- annotateUB sym callStack ub p+     let err = AssertFailureSimError "Undefined behavior encountered" (show (UB.explain ub))+     assert bak p' err++llvmExtensionEval ::+  forall sym bak p ext rtp blocks r ctx.+  (HasLLVMAnn sym, IsSymBackend sym bak) =>+  bak ->+  IntrinsicTypes sym ->+  (Int -> String -> IO ()) ->+  CrucibleState p sym ext rtp blocks r ctx ->+  EvalAppFunc sym LLVMExtensionExpr++llvmExtensionEval bak _iTypes _logFn state eval e =+  let sym = backendGetSym bak in+  case e of+    X86Expr ex -> X86.eval sym eval ex++    LLVM_SideConditions mvar _tp conds val ->+      do let callStack = callStackFromMemVar state mvar+         conds' <- traverse (traverseF (\x -> RV @sym <$> eval x)) (NE.toList conds)+         forM_ conds' (assertSideCondition bak callStack)+         eval val++    LLVM_PointerExpr _w blk off ->+      do blk' <- eval blk+         off' <- eval off+         return (LLVMPointer blk' off')++    LLVM_PointerBlock _w ptr ->+      llvmPointerBlock <$> eval ptr++    LLVM_PointerOffset _w ptr ->+      llvmPointerOffset <$> eval ptr++    LLVM_PointerIte _w c x y ->+      do cond <- eval c+         LLVMPointer xblk xoff <- eval x+         LLVMPointer yblk yoff <- eval y+         blk <- natIte sym cond xblk yblk+         off <- bvIte sym cond xoff yoff+         return (LLVMPointer blk off)
+ src/Lang/Crucible/LLVM/Extension.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Extension+-- Description      : LLVM interface for Crucible+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : rdockins@galois.com+-- Stability        : provisional+--+-- Syntax extension definitions for LLVM+------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.Extension+  ( module Lang.Crucible.LLVM.Extension.Arch+  , module Lang.Crucible.LLVM.Extension.Syntax+  , LLVM+  ) where++import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics ( Generic )++import Lang.Crucible.CFG.Extension++import Lang.Crucible.LLVM.Extension.Arch+import Lang.Crucible.LLVM.Extension.Syntax++-- | The Crucible extension type marker for LLVM.+data LLVM+  deriving (Data, Eq, Generic , Ord, Typeable)++-- -----------------------------------------------------------------------+-- ** Syntax++type instance ExprExtension LLVM = LLVMExtensionExpr+type instance StmtExtension LLVM = LLVMStmt++instance IsSyntaxExtension LLVM
+ src/Lang/Crucible/LLVM/Extension/Arch.hs view
@@ -0,0 +1,64 @@+-- |+-- Module           : Lang.Crucible.LLVM.Arch+-- Description      : Representations of LLVM architectures+-- Copyright        : (c) Galois, Inc 2015-2018+-- License          : BSD3+-- Maintainer       : rdockins@galois.com+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.Extension.Arch+  ( type LLVMArch+  , type X86+  , ArchWidth+  , ArchRepr(..)+  ) where++import           GHC.Generics (Generic)+import           Data.Parameterized (NatRepr)+import           Data.Parameterized.Classes (OrdF(..))+import qualified Data.Parameterized.TH.GADT as U+import           Data.Type.Equality (TestEquality(..))+import           Data.Typeable (Typeable)+import           GHC.TypeLits (Nat)++-- | Data kind for representing LLVM architectures.+--   Currently only X86 variants are supported.+data LLVMArch = X86 Nat+  deriving (Generic, Typeable)++-- | LLVM Architecture tag for X86 variants+--+--   @X86 :: Nat -> LLVMArch@+type X86 = 'X86++-- | Type family defining the native machine word size+--   for a given architecture.+type family ArchWidth (arch :: LLVMArch) :: Nat where+  ArchWidth (X86 wptr) = wptr++-- | Runtime representation of architectures.+data ArchRepr (arch :: LLVMArch) where+  X86Repr :: NatRepr w -> ArchRepr (X86 w)++$(return [])++instance TestEquality ArchRepr where+  testEquality =+    $(U.structuralTypeEquality [t|ArchRepr|]+        [ (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+        ])++instance OrdF ArchRepr where+  compareF =+    $(U.structuralTypeOrd [t|ArchRepr|]+        [ (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|])+        ])
+ src/Lang/Crucible/LLVM/Extension/Syntax.hs view
@@ -0,0 +1,456 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Extension.Syntax+-- Description      : LLVM interface for Crucible+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : rdockins@galois.com+-- Stability        : provisional+--+-- Syntax extension definitions for LLVM+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM.Extension.Syntax where++import           Data.Kind+import           Data.List.NonEmpty (NonEmpty)+import           GHC.TypeLits+import           Data.Text (Text)+import qualified Text.LLVM.AST as L+import           Prettyprinter++import           Data.Functor.Classes (Eq1(..), Ord1(..))+import           Data.Parameterized.Classes+import           Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..))+import qualified Data.Parameterized.TH.GADT as U+import           Data.Parameterized.TraversableF+import           Data.Parameterized.TraversableFC++import           Lang.Crucible.CFG.Common+import           Lang.Crucible.CFG.Extension+import           Lang.Crucible.Types++import           Lang.Crucible.LLVM.Arch.X86 as X86+import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.Errors.UndefinedBehavior( UndefinedBehavior )+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemModel.Type+import           Lang.Crucible.LLVM.Types+++data LLVMSideCondition (f :: CrucibleType -> Type) =+  LLVMSideCondition (f BoolType) (UndefinedBehavior f)++instance TestEqualityC LLVMSideCondition where+  testEqualityC sub (LLVMSideCondition px dx) (LLVMSideCondition py dy) =+    isJust (sub px py) && testEqualityC sub dx dy++instance OrdC LLVMSideCondition where+  compareC sub (LLVMSideCondition px dx) (LLVMSideCondition py dy) =+    toOrdering (sub px py) <> compareC sub dx dy++instance FunctorF LLVMSideCondition where+  fmapF = fmapFDefault++instance FoldableF LLVMSideCondition where+  foldMapF = foldMapFDefault++instance TraversableF LLVMSideCondition where+  traverseF f (LLVMSideCondition p desc) =+      LLVMSideCondition <$> f p <*> traverseF f desc++data LLVMExtensionExpr :: (CrucibleType -> Type) -> (CrucibleType -> Type) where++  X86Expr ::+    !(X86.ExtX86 f t) ->+    LLVMExtensionExpr f t++  LLVM_SideConditions ::+    !(GlobalVar Mem) {- Memory global variable -} ->+    !(TypeRepr tp) ->+    !(NonEmpty (LLVMSideCondition f)) ->+    !(f tp) ->+    LLVMExtensionExpr f tp++  LLVM_PointerExpr ::+    (1 <= w) => !(NatRepr w) -> !(f NatType) -> !(f (BVType w)) ->+    LLVMExtensionExpr f (LLVMPointerType w)++  LLVM_PointerBlock ::+    (1 <= w) => !(NatRepr w) -> !(f (LLVMPointerType w)) ->+    LLVMExtensionExpr f NatType++  LLVM_PointerOffset ::+    (1 <= w) => !(NatRepr w) -> !(f (LLVMPointerType w)) ->+    LLVMExtensionExpr f (BVType w)++  LLVM_PointerIte ::+    (1 <= w) => !(NatRepr w) ->+    !(f BoolType) -> !(f (LLVMPointerType w)) -> !(f (LLVMPointerType w)) ->+    LLVMExtensionExpr f (LLVMPointerType w)+++-- | Extension statements for LLVM.  These statements represent the operations+--   necessary to interact with the LLVM memory model.+data LLVMStmt (f :: CrucibleType -> Type) :: CrucibleType -> Type where++  -- | Indicate the beginning of a new stack frame upon entry to a function.+  LLVM_PushFrame ::+     !Text ->+     !(GlobalVar Mem) {- Memory global variable -} ->+     LLVMStmt f UnitType++  -- | Indicate the end of the current stack frame upon exit from a function.+  LLVM_PopFrame ::+     !(GlobalVar Mem) {- Memory global variable -} ->+     LLVMStmt f UnitType++  -- | Allocate a new memory object in the current stack frame.  This memory+  --   will be automatically deallocated when the corresponding PopFrame+  --   statement is executed.+  LLVM_Alloca ::+     HasPtrWidth wptr =>+     !(NatRepr wptr)       {- Pointer width -} ->+     !(GlobalVar Mem)      {- Memory global variable -} ->+     !(f (BVType wptr))    {- Number of bytes to allocate -} ->+     !Alignment            {- Minimum alignment of this allocation -} ->+     !String               {- Location string to identify this allocation for debugging purposes -} ->+     LLVMStmt f (LLVMPointerType wptr)++  -- | Load a value from the memory.  The load is defined only if+  --   the given pointer is a live pointer; if the bytes in the memory+  --   at that location can be read and reconstructed into a value of the+  --   desired type; and if the given pointer is actually aligned according+  --   to the given alignment value.+  LLVM_Load ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Memory global variable -} ->+     !(f (LLVMPointerType wptr)) {- Pointer to load from -} ->+     !(TypeRepr tp)              {- Expected crucible type of the result -} ->+     !StorageType                {- Storage type -} ->+     !Alignment                  {- Assumed alignment of the pointer -} ->+     LLVMStmt f tp++  -- | Store a value in to the memory.  The store is defined only if the given+  --   pointer is a live pointer; if the given value fits into the memory object+  --   at the location pointed to; and the given pointer is aligned according+  --   to the given alignment value.+  LLVM_Store ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Memory global variable -} ->+     !(f (LLVMPointerType wptr)) {- Pointer to store at -} ->+     !(TypeRepr tp)              {- Crucible type of the value being stored -} ->+     !StorageType                {- Storage type of the value -} ->+     !Alignment                  {- Assumed alignment of the pointer -} ->+     !(f tp)                     {- Value to store -} ->+     LLVMStmt f UnitType++  -- | Clear a region of memory by setting all the bytes in it to the zero byte.+  --   This is primarily used for initializing the value of global variables,+  --   but can also result from zero initializers.+  LLVM_MemClear ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Memory global variable -} ->+     !(f (LLVMPointerType wptr)) {- Pointer to store at -} ->+     !Bytes                      {- Number of bytes to clear -} ->+     LLVMStmt f UnitType++  -- | Load the Crucible function handle that corresponds to a function pointer value.+  --   This load is defined only if the given pointer was previously allocated as+  --   a function pointer value and associated with a Crucible function handle of+  --   the expected type.+  LLVM_LoadHandle ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Memory global variable -} ->+     !(Maybe L.Type)             {- expected LLVM type of the function (used only for pretty-printing) -} ->+     !(f (LLVMPointerType wptr)) {- Pointer to load from -} ->+     !(CtxRepr args)             {- Expected argument types of the function -} ->+     !(TypeRepr ret)             {- Expected return type of the function -} ->+     LLVMStmt f (FunctionHandleType args ret)++  -- | Resolve the given global symbol name to a pointer value.+  LLVM_ResolveGlobal ::+     HasPtrWidth wptr =>+     !(NatRepr wptr)      {- Pointer width -} ->+     !(GlobalVar Mem)     {- Memory global variable -} ->+     GlobalSymbol         {- The symbol to resolve -} ->+     LLVMStmt f (LLVMPointerType wptr)++  -- | Test two pointer values for equality.+  --   Note! This operation is defined only+  --   in case both pointers are live or null.+  LLVM_PtrEq ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Pointer width -} ->+     !(f (LLVMPointerType wptr)) {- First pointer to compare -} ->+     !(f (LLVMPointerType wptr)) {- First pointer to compare -} ->+     LLVMStmt f BoolType++  -- | Test two pointer values for ordering.+  --   Note! This operation is only defined if+  --   both pointers are live pointers into the+  --   same memory object.+  LLVM_PtrLe ::+     HasPtrWidth wptr =>+     !(GlobalVar Mem)            {- Pointer width -} ->+     !(f (LLVMPointerType wptr)) {- First pointer to compare -} ->+     !(f (LLVMPointerType wptr)) {- First pointer to compare -} ->+     LLVMStmt f BoolType++  -- | Add an offset value to a pointer.+  --   Note! This operation is only defined if both+  --   the input pointer is a live pointer, and+  --   the resulting computed pointer remains in the bounds+  --   of its associated memory object (or one past the end).+  LLVM_PtrAddOffset ::+     HasPtrWidth wptr =>+     !(NatRepr wptr)             {- Pointer width -} ->+     !(GlobalVar Mem)            {- Memory global variable -} ->+     !(f (LLVMPointerType wptr)) {- Pointer value -} ->+     !(f (BVType wptr))          {- Offset value -} ->+     LLVMStmt f (LLVMPointerType wptr)++  -- | Compute the offset between two pointer values.+  --   Note! This operation is only defined if both pointers+  --   are live pointers into the same memory object.+  LLVM_PtrSubtract ::+     HasPtrWidth wptr =>+     !(NatRepr wptr)             {- Pointer width -} ->+     !(GlobalVar Mem)            {- Memory global value -} ->+     !(f (LLVMPointerType wptr)) {- First pointer -} ->+     !(f (LLVMPointerType wptr)) {- Second pointer -} ->+     LLVMStmt f (BVType wptr)++  -- | Debug information+  LLVM_Debug ::+    !(LLVM_Dbg f c)              {- Debug variant -} ->+    LLVMStmt f UnitType++-- | Debug statement variants - these have no semantic meaning+data LLVM_Dbg f c where+  -- | Annotates a value pointed to by a pointer with local-variable debug information+  --+  -- <https://llvm.org/docs/SourceLevelDebugging.html#llvm-dbg-addr>+  LLVM_Dbg_Addr ::+    HasPtrWidth wptr =>+    !(f (LLVMPointerType wptr))  {- Pointer to local variable -} ->+    L.DILocalVariable            {- Local variable information -} ->+    L.DIExpression               {- Complex expression -} ->+    LLVM_Dbg f (LLVMPointerType wptr)++  -- | Annotates a value pointed to by a pointer with local-variable debug information+  --+  -- <https://llvm.org/docs/SourceLevelDebugging.html#llvm-dbg-declare>+  LLVM_Dbg_Declare ::+    HasPtrWidth wptr =>+    !(f (LLVMPointerType wptr))  {- Pointer to local variable -} ->+    L.DILocalVariable            {- Local variable information -} ->+    L.DIExpression               {- Complex expression -} ->+    LLVM_Dbg f (LLVMPointerType wptr)++  -- | Annotates a value with local-variable debug information+  --+  -- <https://llvm.org/docs/SourceLevelDebugging.html#llvm-dbg-value>+  LLVM_Dbg_Value ::+    !(TypeRepr c)                {- Type of local variable -} ->+    !(f c)                       {- Value of local variable -} ->+    L.DILocalVariable            {- Local variable information -} ->+    L.DIExpression               {- Complex expression -} ->+    LLVM_Dbg f c++$(return [])++instance TypeApp LLVMExtensionExpr where+  appType e =+    case e of+      X86Expr ex             -> appType ex+      LLVM_SideConditions _ tpr _ _ -> tpr+      LLVM_PointerExpr w _ _ -> LLVMPointerRepr w+      LLVM_PointerBlock _ _  -> NatRepr+      LLVM_PointerOffset w _ -> BVRepr w+      LLVM_PointerIte w _ _ _ -> LLVMPointerRepr w++instance PrettyApp LLVMExtensionExpr where+  ppApp pp e =+    case e of+      X86Expr ex -> ppApp pp ex+      LLVM_SideConditions _ _ _conds ex ->+        pretty "sideConditions" <+> pp ex -- TODO? Print the conditions?+      LLVM_PointerExpr _ blk off ->+        pretty "pointerExpr" <+> pp blk <+> pp off+      LLVM_PointerBlock _ ptr ->+        pretty "pointerBlock" <+> pp ptr+      LLVM_PointerOffset _ ptr ->+        pretty "pointerOffset" <+> pp ptr+      LLVM_PointerIte _ cond x y ->+        pretty "pointerIte" <+> pp cond <+> pp x <+> pp y++instance TestEqualityFC LLVMExtensionExpr where+  testEqualityFC testSubterm =+    $(U.structuralTypeEquality [t|LLVMExtensionExpr|]+       [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+       , (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+       , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+       , (U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|testEquality|])+       , (U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|testEqualityFC testSubterm|])+       , (U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType)+         , [| \x y -> if liftEq (testEqualityC testSubterm) x y then Just Refl else Nothing |]+         )+       ])++instance OrdFC LLVMExtensionExpr where+  compareFC testSubterm =+    $(U.structuralTypeOrd [t|LLVMExtensionExpr|]+       [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+       , (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|])+       , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|])+       , (U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|compareF|])+       , (U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|compareFC testSubterm|])+       , (U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType)+         , [| \x y -> fromOrdering (liftCompare (compareC testSubterm) x y) |]+         )+       ])++instance FunctorFC LLVMExtensionExpr where+  fmapFC = fmapFCDefault++instance FoldableFC LLVMExtensionExpr where+  foldMapFC = foldMapFCDefault+++traverseConds ::+  Applicative m =>+  (forall s. f s -> m (g s)) ->+  NonEmpty (LLVMSideCondition f) ->+  m (NonEmpty (LLVMSideCondition g))+traverseConds f = traverse (traverseF f)+++instance TraversableFC LLVMExtensionExpr where+  traverseFC = $(U.structuralTraversal [t|LLVMExtensionExpr|]+     [(U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|traverseFC|])+     ,(U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType)+      , [| traverseConds |]+      )+     ])++instance TypeApp LLVMStmt where+  appType = \case+    LLVM_PushFrame{} -> knownRepr+    LLVM_PopFrame{} -> knownRepr+    LLVM_Alloca w _ _ _ _ -> LLVMPointerRepr w+    LLVM_Load _ _ tp _ _  -> tp+    LLVM_Store{} -> knownRepr+    LLVM_MemClear{} -> knownRepr+    LLVM_LoadHandle _ _ _ args ret -> FunctionHandleRepr args ret+    LLVM_ResolveGlobal w _ _ -> LLVMPointerRepr w+    LLVM_PtrEq{} -> knownRepr+    LLVM_PtrLe{} -> knownRepr+    LLVM_PtrAddOffset w _ _ _ -> LLVMPointerRepr w+    LLVM_PtrSubtract w _ _ _ -> BVRepr w+    LLVM_Debug{} -> knownRepr++instance PrettyApp LLVMStmt where+  ppApp pp = \case+    LLVM_PushFrame nm mvar ->+       pretty "pushFrame" <+> pretty nm <+> ppGlobalVar mvar+    LLVM_PopFrame mvar  ->+       pretty "popFrame" <+> ppGlobalVar mvar+    LLVM_Alloca _ mvar sz a loc ->+       pretty "alloca" <+> ppGlobalVar mvar <+> pp sz <+> ppAlignment a <+> pretty loc+    LLVM_Load mvar ptr _tpr tp a ->+       pretty "load" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow tp <+> ppAlignment a+    LLVM_Store mvar ptr _tpr tp a v ->+       pretty "store" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow tp <+> ppAlignment a <+> pp v+    LLVM_MemClear mvar ptr len ->+       pretty "memClear" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow len+    LLVM_LoadHandle mvar ltp ptr _args _ret ->+       pretty "loadFunctionHandle" <+> ppGlobalVar mvar <+> pp ptr <+> pretty "as" <+> viaShow ltp+    LLVM_ResolveGlobal _ mvar gs ->+       pretty "resolveGlobal" <+> ppGlobalVar mvar <+> viaShow (globalSymbolName gs)+    LLVM_PtrEq mvar x y ->+       pretty "ptrEq" <+> ppGlobalVar mvar <+> pp x <+> pp y+    LLVM_PtrLe mvar x y ->+       pretty "ptrLe" <+> ppGlobalVar mvar <+> pp x <+> pp y+    LLVM_PtrAddOffset _ mvar x y ->+       pretty "ptrAddOffset" <+> ppGlobalVar mvar <+> pp x <+> pp y+    LLVM_PtrSubtract _ mvar x y ->+       pretty "ptrSubtract" <+> ppGlobalVar mvar <+> pp x <+> pp y+    LLVM_Debug dbg -> ppApp pp dbg++instance PrettyApp LLVM_Dbg where+  ppApp pp = \case+    LLVM_Dbg_Addr    x _ _ -> pretty "dbg.addr"    <+> pp x+    LLVM_Dbg_Declare x _ _ -> pretty "dbg.declare" <+> pp x+    LLVM_Dbg_Value _ x _ _ -> pretty "dbg.value"   <+> pp x++-- TODO: move to a Pretty instance+ppGlobalVar :: GlobalVar Mem -> Doc ann+ppGlobalVar = viaShow++-- TODO: move to a Pretty instance+ppAlignment :: Alignment -> Doc ann+ppAlignment = viaShow++instance TestEqualityFC LLVM_Dbg where+  testEqualityFC testSubterm = $(U.structuralTypeEquality [t|LLVM_Dbg|]+    [(U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+    ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+    ])++instance OrdFC LLVM_Dbg where+  compareFC compareSubterm = $(U.structuralTypeOrd [t|LLVM_Dbg|]+    [(U.DataArg 0 `U.TypeApp` U.AnyType, [|compareSubterm|])+    ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|])+    ])++instance FoldableFC LLVM_Dbg where+  foldMapFC = foldMapFCDefault+instance FunctorFC LLVM_Dbg where+  fmapFC = fmapFCDefault++instance TraversableFC LLVM_Dbg where+  traverseFC = $(U.structuralTraversal [t|LLVM_Dbg|] [])++instance TestEqualityFC LLVMStmt where+  testEqualityFC testSubterm =+    $(U.structuralTypeEquality [t|LLVMStmt|]+       [(U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+       ,(U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+       ,(U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|testEquality|])+       ,(U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+       ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|])+       ,(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|testEqualityFC testSubterm|])+       ])++instance OrdFC LLVMStmt where+  compareFC compareSubterm =+    $(U.structuralTypeOrd [t|LLVMStmt|]+       [(U.DataArg 0 `U.TypeApp` U.AnyType, [|compareSubterm|])+       ,(U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|])+       ,(U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|compareF|])+       ,(U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType, [|compareF|])+       ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|])+       ,(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|compareFC compareSubterm|])+       ])++instance FunctorFC LLVMStmt where+  fmapFC = fmapFCDefault++instance FoldableFC LLVMStmt where+  foldMapFC = foldMapFCDefault++instance TraversableFC LLVMStmt where+  traverseFC =+    $(U.structuralTraversal [t|LLVMStmt|]+      [(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|traverseFC|])+      ])
+ src/Lang/Crucible/LLVM/Globals.hs view
@@ -0,0 +1,420 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Globals+-- Description      : Operations for working with LLVM global variables+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- This module provides support for dealing with LLVM global variables,+-- including initial allocation and populating variables with their+-- initial values.  A @GlobalInitializerMap@ is constructed during+-- module translation and can subsequently be used to populate+-- global variables.  This can either be done all at once using+-- @populateAllGlobals@; or it can be done in a more selective manner,+-- using one of the other \"populate\" operations.+------------------------------------------------------------------------++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Lang.Crucible.LLVM.Globals+  ( initializeMemory+  , initializeAllMemory+  , initializeMemoryConstGlobals+  , populateGlobal+  , populateGlobals+  , populateAllGlobals+  , populateConstGlobals+  , registerFunPtr++  , GlobalInitializerMap+  , makeGlobalMap+  ) where++import           Control.Arrow ((&&&))+import           Control.Monad (foldM)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Except (MonadError(..))+import           Control.Lens hiding (op, (:>) )+import           Data.List (foldl')+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import           Data.String+import           Control.Monad.State (StateT, runStateT, get, put)+import           Data.Maybe (fromMaybe)+import qualified Data.Parameterized.Context as Ctx++import qualified Text.LLVM.AST as L++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.NatRepr as NatRepr++import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.MemModel+import qualified Lang.Crucible.LLVM.MemModel.Generic as G+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import           Lang.Crucible.LLVM.Translation.Constant+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.Backend++import           What4.Interface++import           GHC.Stack++------------------------------------------------------------------------+-- GlobalInitializerMap++-- | A @GlobalInitializerMap@ records the initialized values of globals in an @L.Module@.+--+-- The @Left@ constructor is used to signal errors in translation,+-- which can happen when:+--  * The declaration is ill-typed+--  * The global isn't linked (@extern global@)+--+-- The @Nothing@ constructor is used to signal that the global isn't actually a+-- compile-time constant.+--+-- These failures are as granular as possible (attached to the values)+-- so that simulation still succeeds if the module has a bad global that the+-- verified function never touches.+--+-- To actually initialize globals, saw-script translates them into+-- instances of @MemModel.LLVMVal@.+type GlobalInitializerMap = Map L.Symbol (L.Global, Either String (MemType, Maybe LLVMConst))+++------------------------------------------------------------------------+-- makeGlobalMap++-- | @makeGlobalMap@ creates a map from names of LLVM global variables+-- to the values of their initializers, if any are included in the module.+makeGlobalMap :: forall arch wptr. (?lc :: TypeContext, HasPtrWidth wptr)+              => LLVMContext arch+              -> L.Module+              -> GlobalInitializerMap+makeGlobalMap ctx m = foldl' addAliases globalMap (Map.toList (llvmGlobalAliases ctx))++  where+   addAliases mp (glob, aliases) =+        case Map.lookup glob mp of+          Just initzr -> insertAll (map L.aliasName (Set.toList aliases)) initzr mp+          Nothing     -> mp -- should this be an error/exception?++   globalMap = Map.fromList $ map (L.globalSym &&& (id &&& globalToConst))+                                  (L.modGlobals m)++   insertAll ks v mp = foldr (flip Map.insert v) mp ks++   -- Catch the error from @transConstant@, turn it into @Either@+   globalToConst :: L.Global -> Either String (MemType, Maybe LLVMConst)+   globalToConst g =+     catchError+       (globalToConst' g)+       (\err -> Left $+         "Encountered error while processing global "+           ++ show (LPP.ppSymbol (L.globalSym g))+           ++ ": "+           ++ err)++   globalToConst' :: forall m. (MonadError String m)+                  => L.Global -> m (MemType, Maybe LLVMConst)+   globalToConst' g =+     do let ?lc  = ctx^.llvmTypeCtx -- implicitly passed to transConstant+        let gty  = L.globalType g+        let gval = L.globalValue g+        mt  <- liftMemType gty+        val <- traverse (transConstant' mt) gval+        return (mt, val)++-------------------------------------------------------------------------+-- initializeMemory++-- | Build the initial memory for an LLVM program.  Note, this process+-- allocates space for global variables, but does not set their+-- initial values.+initializeAllMemory+   :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+      , ?memOpts :: MemOptions )+   => bak+   -> LLVMContext arch+   -> L.Module+   -> IO (MemImpl sym)+initializeAllMemory = initializeMemory (const True)++initializeMemoryConstGlobals+   :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+      , ?memOpts :: MemOptions )+   => bak+   -> LLVMContext arch+   -> L.Module+   -> IO (MemImpl sym)+initializeMemoryConstGlobals = initializeMemory (L.gaConstant . L.globalAttrs)++initializeMemory+   :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+      , ?memOpts :: MemOptions )+   => (L.Global -> Bool)+   -> bak+   -> LLVMContext arch+   -> L.Module+   -> IO (MemImpl sym)+initializeMemory predicate bak llvm_ctx llvmModl = do+   -- Create initial memory of appropriate endianness+   let ?lc = llvm_ctx^.llvmTypeCtx+   let dl = llvmDataLayout ?lc+   let endianness = dl^.intLayout+   mem0 <- emptyMem endianness++   -- allocate pointers values for function symbols, but do not+   -- yet bind them to function handles+   let decls = map Left (L.modDeclares llvmModl) ++ map Right (L.modDefines llvmModl)+   mem <- foldM (allocLLVMFunPtr bak llvm_ctx) mem0 decls++   -- Allocate global values+   let globAliases = llvmGlobalAliases llvm_ctx+   let globals     = L.modGlobals llvmModl+   gs_alloc <- mapM (\g -> do+                        let err msg = malformedLLVMModule+                                    ("Invalid type for global" <> fromString (show (L.globalSym g)))+                                    [fromString msg]+                        ty <- either err return $ liftMemType $ L.globalType g+                        let sz      = memTypeSize dl ty+                        let tyAlign = memTypeAlign dl ty+                        let aliases = map L.aliasName . Set.toList $+                              fromMaybe Set.empty (Map.lookup (L.globalSym g) globAliases)+                        -- LLVM documentation regarding global variable alignment:+                        --+                        -- An explicit alignment may be specified for+                        -- a global, which must be a power of 2. If+                        -- not present, or if the alignment is set to+                        -- zero, the alignment of the global is set by+                        -- the target to whatever it feels+                        -- convenient. If an explicit alignment is+                        -- specified, the global is forced to have+                        -- exactly that alignment.+                        alignment <-+                          case L.globalAlign g of+                            Just a | a > 0 ->+                              case toAlignment (toBytes a) of+                                Nothing -> fail $ "Invalid alignemnt: " ++ show a ++ "\n  " +++                                                  "specified for global: " ++ show (L.globalSym g)+                                Just al -> return al+                            _ -> return tyAlign+                        return (g, aliases, sz, alignment))+                    globals+   allocGlobals bak (filter (\(g, _, _, _) -> predicate g) gs_alloc) mem+++allocLLVMFunPtr ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  LLVMContext arch ->+  MemImpl sym ->+  Either L.Declare L.Define ->+  IO (MemImpl sym)+allocLLVMFunPtr bak llvm_ctx mem decl =+  do let (symbol, displayString) =+           case decl of+             Left d ->+               let s@(L.Symbol nm) = L.decName d+                in ( s, "[external function] " ++ nm )+             Right d ->+               let s@(L.Symbol nm) = L.defName d+                in ( s, "[defined function ] " ++ nm)+     let funAliases = llvmFunctionAliases llvm_ctx+     let aliases = map L.aliasName $ maybe [] Set.toList $ Map.lookup symbol funAliases+     (_ptr, mem') <- registerFunPtr bak mem displayString symbol aliases+     return mem'++-- | Create a global allocation assocated with a function+registerFunPtr ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  -- | Display name+  String ->+  -- | Function name+  L.Symbol ->+  -- | Aliases+  [L.Symbol] ->+  IO (LLVMPtr sym wptr, MemImpl sym)+registerFunPtr bak mem displayName nm aliases = do+  let sym = backendGetSym bak+  z <- bvLit sym ?ptrWidth (BV.zero ?ptrWidth)+  (ptr, mem') <- doMalloc bak G.GlobalAlloc G.Immutable displayName mem z noAlignment+  return $ (ptr, registerGlobal mem' (nm:aliases) ptr)++------------------------------------------------------------------------+-- ** populateGlobals++-- | Populate the globals mentioned in the given @GlobalInitializerMap@+--   provided they satisfy the given filter function.+--+--   This will (necessarily) populate any globals that the ones in the+--   filtered list transitively reference.+populateGlobals ::+  ( ?lc :: TypeContext+  , ?memOpts :: MemOptions+  , 16 <= wptr+  , HasPtrWidth wptr+  , HasLLVMAnn sym+  , IsSymBackend sym bak) =>+  (L.Global -> Bool)   {- ^ Filter function, globals that cause this to return true will be populated -} ->+  bak ->+  GlobalInitializerMap ->+  MemImpl sym ->+  IO (MemImpl sym)+populateGlobals select bak gimap mem0 = foldM f mem0 (Map.elems gimap)+  where+  f mem (gl, _) | not (select gl)    = return mem+  f _   (_,  Left msg)               = fail msg+  f mem (gl, Right (mty, Just cval)) = populateGlobal bak gl mty cval gimap mem+  f mem (gl, Right (mty, Nothing))   = populateExternalGlobal bak gl mty mem+++-- | Populate all the globals mentioned in the given @GlobalInitializerMap@.+populateAllGlobals ::+  ( ?lc :: TypeContext+  , ?memOpts :: MemOptions+  , 16 <= wptr+  , HasPtrWidth wptr+  , HasLLVMAnn sym+  , IsSymBackend sym bak) =>+  bak ->+  GlobalInitializerMap ->+  MemImpl sym ->+  IO (MemImpl sym)+populateAllGlobals = populateGlobals (const True)+++-- | Populate only the constant global variables mentioned in the+--   given @GlobalInitializerMap@ (and any they transitively refer to).+populateConstGlobals ::+  ( ?lc :: TypeContext+  , ?memOpts :: MemOptions+  , 16 <= wptr+  , HasPtrWidth wptr+  , HasLLVMAnn sym+  , IsSymBackend sym bak) =>+  bak ->+  GlobalInitializerMap ->+  MemImpl sym ->+  IO (MemImpl sym)+populateConstGlobals = populateGlobals f+  where f = L.gaConstant . L.globalAttrs+++-- | Ordinarily external globals do not receive initalizing writes.  However,+--   when 'lax-loads-and-stores` is enabled in the `stable-symbolic` mode, we+--   populate external global variables with fresh bytes.+populateExternalGlobal ::+  ( ?lc :: TypeContext+  , 16 <= wptr+  , HasPtrWidth wptr+  , IsSymBackend sym bak+  , HasLLVMAnn sym+  , HasCallStack+  , ?memOpts :: MemOptions+  ) =>+  bak ->+  L.Global {- ^ The global to populate -} ->+  MemType {- ^ Type of the global -} ->+  MemImpl sym ->+  IO (MemImpl sym)+populateExternalGlobal bak gl memty mem+  | laxLoadsAndStores ?memOpts+  , indeterminateLoadBehavior ?memOpts == StableSymbolic++  =  do let sym = backendGetSym bak+        bytes <- freshConstant sym emptySymbol+                    (BaseArrayRepr (Ctx.singleton $ BaseBVRepr ?ptrWidth)+                        (BaseBVRepr (knownNat @8)))+        let dl = llvmDataLayout ?lc+        let sz = memTypeSize dl memty+        let tyAlign = memTypeAlign dl memty+        sz' <- bvLit sym PtrWidth (bytesToBV PtrWidth sz)+        ptr <- doResolveGlobal bak mem (L.globalSym gl)+        doArrayConstStore bak mem ptr tyAlign bytes sz'++  | otherwise = return mem+++-- | Write the value of the given LLVMConst into the given global variable.+--   This is intended to be used at initialization time, and will populate+--   even read-only global data.+populateGlobal :: forall sym bak wptr.+  ( ?lc :: TypeContext+  , 16 <= wptr+  , HasPtrWidth wptr+  , IsSymBackend sym bak+  , HasLLVMAnn sym+  , ?memOpts :: MemOptions+  , HasCallStack+  ) =>+  bak ->+  L.Global {- ^ The global to populate -} ->+  MemType {- ^ Type of the global -} ->+  LLVMConst {- ^ Constant value to initialize with -} ->+  GlobalInitializerMap ->+  MemImpl sym ->+  IO (MemImpl sym)+populateGlobal bak gl memty cval giMap mem =+  do let sym = backendGetSym bak+     let alignment = memTypeAlign (llvmDataLayout ?lc) memty++     -- So that globals can populate and look up the globals they reference+     -- during initialization+     let populateRec :: HasCallStack+                     => L.Symbol -> StateT (MemImpl sym) IO (LLVMPtr sym wptr)+         populateRec symbol = do+           memimpl0 <- get+           memimpl <-+            case Map.lookup symbol (memImplGlobalMap mem) of+              Just _  -> pure memimpl0 -- We already populated this one+              Nothing ->+                -- For explanations of the various modes of failure, see the+                -- comment on 'GlobalInitializerMap'.+                case Map.lookup symbol giMap of+                  Nothing -> fail $ unlines $+                    [ "Couldn't find global variable: " ++ show symbol ]+                  Just (glob, Left str) -> fail $ unlines $+                    [ "Couldn't find global variable's initializer: " +++                        show symbol+                    , "Reason:"+                    , str+                    , "Full definition:"+                    , show glob+                    ]+                  Just (glob, Right (_, Nothing)) -> fail $ unlines $+                    [ "Global was not a compile-time constant:" ++ show symbol+                    , "Full definition:"+                    , show glob+                    ]+                  Just (glob, Right (memty_, Just cval_)) ->+                    liftIO $ populateGlobal bak glob memty_ cval_ giMap memimpl0+           put memimpl+           liftIO $ doResolveGlobal bak memimpl symbol++     ty <- toStorableType memty+     ptr <- doResolveGlobal bak mem (L.globalSym gl)+     (val, mem') <- runStateT (constToLLVMValP sym populateRec cval) mem+     storeConstRaw bak mem' ptr ty alignment val
+ src/Lang/Crucible/LLVM/Intrinsics.hs view
@@ -0,0 +1,423 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics+-- Description      : Override definitions for LLVM intrinsic and basic+--                    library functions+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.Intrinsics+( LLVM+, llvmIntrinsicTypes+, LLVMOverride(..)++, register_llvm_overrides+, register_llvm_overrides_+, llvmDeclToFunHandleRepr++, module Lang.Crucible.LLVM.Intrinsics.Common+, module Lang.Crucible.LLVM.Intrinsics.Options+) where++import           Control.Lens hiding (op, (:>), Empty)+import           Control.Monad (forM_)+import           Control.Monad.Reader (ReaderT(..))+import           Control.Monad.Trans.Maybe+import           Data.Foldable (asum)+import           Data.List (stripPrefix, tails, isPrefixOf)+import qualified Text.LLVM.AST as L++import qualified ABI.Itanium as ABI+import qualified Data.Parameterized.Map as MapF++import           What4.Interface++import           Lang.Crucible.Backend+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.Intrinsics+import           Lang.Crucible.Simulator.OverrideSim++import           Lang.Crucible.LLVM.Extension (ArchWidth, LLVM)+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext (TypeContext)++import           Lang.Crucible.LLVM.Intrinsics.Common+import qualified Lang.Crucible.LLVM.Intrinsics.LLVM as LLVM+import qualified Lang.Crucible.LLVM.Intrinsics.Libc as Libc+import qualified Lang.Crucible.LLVM.Intrinsics.Libcxx as Libcxx+import           Lang.Crucible.LLVM.Intrinsics.Options++llvmIntrinsicTypes :: IsSymInterface sym => IntrinsicTypes sym+llvmIntrinsicTypes =+   MapF.insert (knownSymbol :: SymbolRepr "LLVM_memory") IntrinsicMuxFn $+   MapF.insert (knownSymbol :: SymbolRepr "LLVM_pointer") IntrinsicMuxFn $+   MapF.empty++-- | Register all declare and define overrides+register_llvm_overrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch+  , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  L.Module ->+  [OverrideTemplate p sym arch rtp l a] {- ^ Additional "define" overrides -} ->+  [OverrideTemplate p sym arch rtp l a] {- ^ Additional "declare" overrides -} ->+  LLVMContext arch ->+  OverrideSim p sym LLVM rtp l a ()+register_llvm_overrides llvmModule defineOvrs declareOvrs llvmctx =+  do register_llvm_define_overrides llvmModule defineOvrs llvmctx+     register_llvm_declare_overrides llvmModule declareOvrs llvmctx++-- | Filter the initial list of templates to only those that could+-- possibly match the given declaration based on straightforward,+-- relatively cheap string tests on the name of the declaration.+--+-- Any remaining templates will then examine the declaration in+-- more detail, including examining function arguments+-- and the structure of C++ demangled names to extract more information.+filterTemplates ::+  [OverrideTemplate p sym arch rtp l a] ->+  L.Declare ->+  [OverrideTemplate p sym arch rtp l a]+filterTemplates ts decl = filter (f . overrideTemplateMatcher) ts+ where+ L.Symbol nm = L.decName decl++ f (ExactMatch x)       = x == nm+ f (PrefixMatch pfx)    = pfx `isPrefixOf` nm+ f (SubstringsMatch as) = filterSubstrings as nm++ filterSubstrings [] _ = True+ filterSubstrings (a:as) xs =+   case restAfterSubstring a xs of+     Nothing   -> False+     Just rest -> filterSubstrings as rest++ restAfterSubstring :: String -> String -> Maybe String+ restAfterSubstring sub xs = asum [ stripPrefix sub tl | tl <- tails xs ]+++-- | Helper function for registering overrides+register_llvm_overrides_ ::+  LLVMContext arch ->+  [OverrideTemplate p sym arch rtp l a] ->+  [L.Declare] ->+  OverrideSim p sym LLVM rtp l a ()+register_llvm_overrides_ llvmctx acts decls =+    forM_ decls $ \decl ->+      do let acts' = filterTemplates acts decl+         let L.Symbol nm = L.decName decl+         let declnm = either (const Nothing) Just $ ABI.demangleName nm+         runMaybeT (flip runReaderT (decl,declnm,llvmctx) $ asum (map overrideTemplateAction acts'))++register_llvm_define_overrides ::+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) =>+  L.Module ->+  [OverrideTemplate p sym arch rtp l a] ->+  LLVMContext arch ->+  OverrideSim p sym LLVM rtp l a ()+register_llvm_define_overrides llvmModule addlOvrs llvmctx =+  let ?lc = llvmctx^.llvmTypeCtx in+  register_llvm_overrides_ llvmctx (addlOvrs ++ define_overrides) $+     (allModuleDeclares llvmModule)++register_llvm_declare_overrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch+  , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  L.Module ->+  [OverrideTemplate p sym arch rtp l a] ->+  LLVMContext arch ->+  OverrideSim p sym LLVM rtp l a ()+register_llvm_declare_overrides llvmModule addlOvrs llvmctx =+  let ?lc = llvmctx^.llvmTypeCtx+  in register_llvm_overrides_ llvmctx (addlOvrs ++ declare_overrides) $+       L.modDeclares llvmModule+++-- | Register overrides for declared-but-not-defined functions+declare_overrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch+  , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  [OverrideTemplate p sym arch rtp l a]+declare_overrides =+  [ basic_llvm_override LLVM.llvmLifetimeStartOverride+  , basic_llvm_override LLVM.llvmLifetimeEndOverride+  , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload "start" (knownNat @8))+  , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload "end" (knownNat @8))+  , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload_opaque "start")+  , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload_opaque "end")+  , basic_llvm_override (LLVM.llvmInvariantStartOverride (knownNat @8))+  , basic_llvm_override LLVM.llvmInvariantStartOverride_opaque+  , basic_llvm_override (LLVM.llvmInvariantEndOverride (knownNat @8))+  , basic_llvm_override LLVM.llvmInvariantEndOverride_opaque++  , basic_llvm_override LLVM.llvmAssumeOverride+  , basic_llvm_override LLVM.llvmTrapOverride+  , basic_llvm_override LLVM.llvmUBSanTrapOverride++  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32+  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32_noalign+  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32_noalign_opaque+  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64+  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64_noalign+  , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64_noalign_opaque++  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32+  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32_noalign+  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32_noalign_opaque+  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64+  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64_noalign+  , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64_noalign_opaque++  , basic_llvm_override LLVM.llvmMemsetOverride_8_32+  , basic_llvm_override LLVM.llvmMemsetOverride_8_32_noalign+  , basic_llvm_override LLVM.llvmMemsetOverride_8_32_noalign_opaque+  , basic_llvm_override LLVM.llvmMemsetOverride_8_64+  , basic_llvm_override LLVM.llvmMemsetOverride_8_64_noalign+  , basic_llvm_override LLVM.llvmMemsetOverride_8_64_noalign_opaque++  , basic_llvm_override LLVM.llvmObjectsizeOverride_32+  , basic_llvm_override LLVM.llvmObjectsizeOverride_64++  , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null+  , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null++  , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null_dynamic+  , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null_dynamic++  , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null_dynamic_opaque+  , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null_dynamic_opaque++  , basic_llvm_override LLVM.llvmPrefetchOverride+  , basic_llvm_override LLVM.llvmPrefetchOverride_opaque+  , basic_llvm_override LLVM.llvmPrefetchOverride_preLLVM10++  , basic_llvm_override LLVM.llvmStacksave+  , basic_llvm_override LLVM.llvmStackrestore++  , polymorphic1_llvm_override "llvm.ctlz"+      (\w -> SomeLLVMOverride (LLVM.llvmCtlz w))+  , polymorphic1_llvm_override "llvm.cttz"+      (\w -> SomeLLVMOverride (LLVM.llvmCttz w))+  , polymorphic1_llvm_override "llvm.ctpop"+      (\w -> SomeLLVMOverride (LLVM.llvmCtpop w))+  , polymorphic1_llvm_override "llvm.bitreverse"+      (\w -> SomeLLVMOverride (LLVM.llvmBitreverse w))+  , polymorphic1_llvm_override "llvm.abs"+      (\w -> SomeLLVMOverride (LLVM.llvmAbsOverride w))++  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @2))  -- 16 = 2 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @4))  -- 32 = 4 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @6))  -- 48 = 6 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @8))  -- 64 = 8 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @10)) -- 80 = 10 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @12)) -- 96 = 12 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @14)) -- 112 = 14 * 8+  , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @16)) -- 128 = 16 * 8++  , polymorphic1_llvm_override "llvm.fshl"+      (\w -> SomeLLVMOverride (LLVM.llvmFshl w))+  , polymorphic1_llvm_override "llvm.fshr"+      (\w -> SomeLLVMOverride (LLVM.llvmFshr w))++  , polymorphic1_llvm_override "llvm.expect"+      (\w -> SomeLLVMOverride (LLVM.llvmExpectOverride w))+  , polymorphic1_llvm_override "llvm.sadd.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmSaddWithOverflow w))+  , polymorphic1_llvm_override "llvm.uadd.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmUaddWithOverflow w))+  , polymorphic1_llvm_override "llvm.ssub.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmSsubWithOverflow w))+  , polymorphic1_llvm_override "llvm.usub.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmUsubWithOverflow w))+  , polymorphic1_llvm_override "llvm.smul.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmSmulWithOverflow w))+  , polymorphic1_llvm_override "llvm.umul.with.overflow"+      (\w -> SomeLLVMOverride (LLVM.llvmUmulWithOverflow w))++  , polymorphic1_llvm_override "llvm.smax"+      (\w -> SomeLLVMOverride (LLVM.llvmSmax w))+  , polymorphic1_llvm_override "llvm.smin"+      (\w -> SomeLLVMOverride (LLVM.llvmSmin w))+  , polymorphic1_llvm_override "llvm.umax"+      (\w -> SomeLLVMOverride (LLVM.llvmUmax w))+  , polymorphic1_llvm_override "llvm.umin"+      (\w -> SomeLLVMOverride (LLVM.llvmUmin w))++  , basic_llvm_override LLVM.llvmCopysignOverride_F32+  , basic_llvm_override LLVM.llvmCopysignOverride_F64+  , basic_llvm_override LLVM.llvmFabsF32+  , basic_llvm_override LLVM.llvmFabsF64++  , basic_llvm_override LLVM.llvmCeilOverride_F32+  , basic_llvm_override LLVM.llvmCeilOverride_F64+  , basic_llvm_override LLVM.llvmFloorOverride_F32+  , basic_llvm_override LLVM.llvmFloorOverride_F64+  , basic_llvm_override LLVM.llvmSqrtOverride_F32+  , basic_llvm_override LLVM.llvmSqrtOverride_F64+  , basic_llvm_override LLVM.llvmSinOverride_F32+  , basic_llvm_override LLVM.llvmSinOverride_F64+  , basic_llvm_override LLVM.llvmCosOverride_F32+  , basic_llvm_override LLVM.llvmCosOverride_F64+  , basic_llvm_override LLVM.llvmPowOverride_F32+  , basic_llvm_override LLVM.llvmPowOverride_F64+  , basic_llvm_override LLVM.llvmExpOverride_F32+  , basic_llvm_override LLVM.llvmExpOverride_F64+  , basic_llvm_override LLVM.llvmLogOverride_F32+  , basic_llvm_override LLVM.llvmLogOverride_F64+  , basic_llvm_override LLVM.llvmExp2Override_F32+  , basic_llvm_override LLVM.llvmExp2Override_F64+  , basic_llvm_override LLVM.llvmLog2Override_F32+  , basic_llvm_override LLVM.llvmLog2Override_F64+  , basic_llvm_override LLVM.llvmLog10Override_F32+  , basic_llvm_override LLVM.llvmLog10Override_F64+  , basic_llvm_override LLVM.llvmFmaOverride_F32+  , basic_llvm_override LLVM.llvmFmaOverride_F64+  , basic_llvm_override LLVM.llvmFmuladdOverride_F32+  , basic_llvm_override LLVM.llvmFmuladdOverride_F64+  , basic_llvm_override LLVM.llvmIsFpclassOverride_F32+  , basic_llvm_override LLVM.llvmIsFpclassOverride_F64++  -- C standard library functions+  , basic_llvm_override Libc.llvmAbortOverride+  , basic_llvm_override Libc.llvmAssertRtnOverride+  , basic_llvm_override Libc.llvmAssertFailOverride+  , basic_llvm_override Libc.llvmMemcpyOverride+  , basic_llvm_override Libc.llvmMemcpyChkOverride+  , basic_llvm_override Libc.llvmMemmoveOverride+  , basic_llvm_override Libc.llvmMemsetOverride+  , basic_llvm_override Libc.llvmMemsetChkOverride+  , basic_llvm_override Libc.llvmMallocOverride+  , basic_llvm_override Libc.llvmCallocOverride+  , basic_llvm_override Libc.llvmFreeOverride+  , basic_llvm_override Libc.llvmReallocOverride+  , basic_llvm_override Libc.llvmStrlenOverride+  , basic_llvm_override Libc.llvmPrintfOverride+  , basic_llvm_override Libc.llvmPrintfChkOverride+  , basic_llvm_override Libc.llvmPutsOverride+  , basic_llvm_override Libc.llvmPutCharOverride+  , basic_llvm_override Libc.llvmExitOverride+  , basic_llvm_override Libc.llvmGetenvOverride+  , basic_llvm_override Libc.llvmHtonlOverride+  , basic_llvm_override Libc.llvmHtonsOverride+  , basic_llvm_override Libc.llvmNtohlOverride+  , basic_llvm_override Libc.llvmNtohsOverride+  , basic_llvm_override Libc.llvmAbsOverride+  , basic_llvm_override Libc.llvmLAbsOverride_32+  , basic_llvm_override Libc.llvmLAbsOverride_64+  , basic_llvm_override Libc.llvmLLAbsOverride++  , basic_llvm_override Libc.llvmCeilOverride+  , basic_llvm_override Libc.llvmCeilfOverride+  , basic_llvm_override Libc.llvmFloorOverride+  , basic_llvm_override Libc.llvmFloorfOverride+  , basic_llvm_override Libc.llvmFmaOverride+  , basic_llvm_override Libc.llvmFmafOverride+  , basic_llvm_override Libc.llvmIsinfOverride+  , basic_llvm_override Libc.llvm__isinfOverride+  , basic_llvm_override Libc.llvm__isinffOverride+  , basic_llvm_override Libc.llvmIsnanOverride+  , basic_llvm_override Libc.llvm__isnanOverride+  , basic_llvm_override Libc.llvm__isnanfOverride+  , basic_llvm_override Libc.llvmSqrtOverride+  , basic_llvm_override Libc.llvmSqrtfOverride+  , basic_llvm_override Libc.llvmSinOverride+  , basic_llvm_override Libc.llvmSinfOverride+  , basic_llvm_override Libc.llvmCosOverride+  , basic_llvm_override Libc.llvmCosfOverride+  , basic_llvm_override Libc.llvmTanOverride+  , basic_llvm_override Libc.llvmTanfOverride+  , basic_llvm_override Libc.llvmAsinOverride+  , basic_llvm_override Libc.llvmAsinfOverride+  , basic_llvm_override Libc.llvmAcosOverride+  , basic_llvm_override Libc.llvmAcosfOverride+  , basic_llvm_override Libc.llvmAtanOverride+  , basic_llvm_override Libc.llvmAtanfOverride+  , basic_llvm_override Libc.llvmSinhOverride+  , basic_llvm_override Libc.llvmSinhfOverride+  , basic_llvm_override Libc.llvmCoshOverride+  , basic_llvm_override Libc.llvmCoshfOverride+  , basic_llvm_override Libc.llvmTanhOverride+  , basic_llvm_override Libc.llvmTanhfOverride+  , basic_llvm_override Libc.llvmAsinhOverride+  , basic_llvm_override Libc.llvmAsinhfOverride+  , basic_llvm_override Libc.llvmAcoshOverride+  , basic_llvm_override Libc.llvmAcoshfOverride+  , basic_llvm_override Libc.llvmAtanhOverride+  , basic_llvm_override Libc.llvmAtanhfOverride+  , basic_llvm_override Libc.llvmHypotOverride+  , basic_llvm_override Libc.llvmHypotfOverride+  , basic_llvm_override Libc.llvmAtan2Override+  , basic_llvm_override Libc.llvmAtan2fOverride+  , basic_llvm_override Libc.llvmPowfOverride+  , basic_llvm_override Libc.llvmPowOverride+  , basic_llvm_override Libc.llvmExpOverride+  , basic_llvm_override Libc.llvmExpfOverride+  , basic_llvm_override Libc.llvmLogOverride+  , basic_llvm_override Libc.llvmLogfOverride+  , basic_llvm_override Libc.llvmExpm1Override+  , basic_llvm_override Libc.llvmExpm1fOverride+  , basic_llvm_override Libc.llvmLog1pOverride+  , basic_llvm_override Libc.llvmLog1pfOverride+  , basic_llvm_override Libc.llvmExp2Override+  , basic_llvm_override Libc.llvmExp2fOverride+  , basic_llvm_override Libc.llvmLog2Override+  , basic_llvm_override Libc.llvmLog2fOverride+  , basic_llvm_override Libc.llvmExp10Override+  , basic_llvm_override Libc.llvmExp10fOverride+  , basic_llvm_override Libc.llvmLog10Override+  , basic_llvm_override Libc.llvmLog10fOverride++  , basic_llvm_override Libc.cxa_atexitOverride+  , basic_llvm_override Libc.posixMemalignOverride++  -- C++ standard library functions+  , Libcxx.register_cpp_override Libcxx.endlOverride++  -- Some architecture-dependent intrinsics+  , basic_llvm_override LLVM.llvmX86_SSE2_storeu_dq+  , basic_llvm_override LLVM.llvmX86_pclmulqdq+  ]+++-- | Register those overrides that should apply even when the corresponding+-- function has a definition+define_overrides ::+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?lc :: TypeContext) =>+  [OverrideTemplate p sym arch rtp l a]+define_overrides =+  [ Libcxx.register_cpp_override Libcxx.putToOverride12+  , Libcxx.register_cpp_override Libcxx.putToOverride9+  , Libcxx.register_cpp_override Libcxx.endlOverride+  , Libcxx.register_cpp_override Libcxx.sentryOverride+  , Libcxx.register_cpp_override Libcxx.sentryBoolOverride+  ]++{-+Note [Overrides involving (unsigned) long]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Registering overrides for functions with `long` argument or result types is+tricky, as the size of a `long` varies wildly between different operating+systems and architectures. On Linux and macOS, `long` is 32 or 64 bits on+32- or 64-bit architectures, respectively. On Windows, however, `long` is+always 32 bits, regardless of architecture. There is a similar story for the+`unsigned long` type as well.++To ensure that overrides for functions involving `long` are (at least to some+degree) portable, we register each override for `long`-using function twice:+once where `long` is assumed to be 32 bits, and once again where `long` is+assumed to be 64 bits. This is a somewhat heavy-handed solution, but it avoids+the need to predict what size `long` will be on a given target ahead of time.+-}
+ src/Lang/Crucible/LLVM/Intrinsics/Common.hs view
@@ -0,0 +1,388 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Common+-- Description      : Types used in override definitions+-- Copyright        : (c) Galois, Inc 2015-2019+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Common+  ( LLVMOverride(..)+  , SomeLLVMOverride(..)+  , RegOverrideM+  , llvmSizeT+  , llvmSSizeT+  , OverrideTemplate(..)+  , TemplateMatcher(..)+  , callStackFromMemVar'+    -- ** register_llvm_override+  , basic_llvm_override+  , polymorphic1_llvm_override++  , build_llvm_override+  , register_llvm_override+  , register_1arg_polymorphic_override+  , bind_llvm_handle+  , bind_llvm_func+  , do_register_llvm_override+  , alloc_and_register_override+  ) where++import qualified Text.LLVM.AST as L++import           Control.Applicative (empty)+import           Control.Monad (when)+import           Control.Monad.IO.Class (liftIO)+import           Control.Lens+import           Control.Monad.Reader (ReaderT, ask, lift)+import           Control.Monad.Trans.Maybe (MaybeT)+import qualified Data.List as List+import qualified Data.Text as Text+import           Numeric (readDec)++import qualified ABI.Itanium as ABI+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.Some (Some(..))+import           Data.Parameterized.TraversableFC (fmapFC)++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common (GlobalVar)+import           Lang.Crucible.Simulator.ExecutionTree (FnState(UseOverride))+import           Lang.Crucible.FunctionHandle (FnHandle, mkHandle')+import           Lang.Crucible.Panic (panic)+import           Lang.Crucible.Simulator (stateContext, simHandleAllocator)+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Utils.MonadVerbosity (getLogFunction)+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Types++import           What4.FunctionName++import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.Eval (callStackFromMemVar)+import           Lang.Crucible.LLVM.Globals (registerFunPtr)+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack)+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Types++-- | This type represents an implementation of an LLVM intrinsic function in+-- Crucible.+data LLVMOverride p sym args ret =+  LLVMOverride+  { llvmOverride_declare :: L.Declare    -- ^ An LLVM name and signature for this intrinsic+  , llvmOverride_args    :: CtxRepr args -- ^ A representation of the argument types+  , llvmOverride_ret     :: TypeRepr ret -- ^ A representation of the return type+  , llvmOverride_def ::+       forall bak.+         IsSymBackend sym bak =>+         GlobalVar Mem ->+         bak ->+         Ctx.Assignment (RegEntry sym) args ->+         forall rtp args' ret'.+         OverrideSim p sym LLVM rtp args' ret' (RegValue sym ret)+    -- ^ The implementation of the intrinsic in the simulator monad+    -- (@OverrideSim@).+  }++data SomeLLVMOverride p sym =+  forall args ret. SomeLLVMOverride (LLVMOverride p sym args ret)++-- | Convenient LLVM representation of the @size_t@ type.+llvmSizeT :: HasPtrWidth wptr => L.Type+llvmSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth++-- | Convenient LLVM representation of the @ssize_t@ type.+llvmSSizeT :: HasPtrWidth wptr => L.Type+llvmSSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth++data OverrideTemplate p sym arch rtp l a =+  OverrideTemplate+  { overrideTemplateMatcher :: TemplateMatcher+  , overrideTemplateAction :: RegOverrideM p sym arch rtp l a ()+  }++-- | This type controls whether an override is installed for a given name found in a module.+--  See 'filterTemplates'.+data TemplateMatcher+  = ExactMatch String+  | PrefixMatch String+  | SubstringsMatch [String]++type RegOverrideM p sym arch rtp l a =+  ReaderT (L.Declare, Maybe ABI.DecodedName, LLVMContext arch)+    (MaybeT (OverrideSim p sym LLVM rtp l a))++callStackFromMemVar' ::+  GlobalVar Mem ->+  OverrideSim p sym ext r args ret CallStack+callStackFromMemVar' mvar = use (to (flip callStackFromMemVar mvar))++------------------------------------------------------------------------+-- ** register_llvm_override++newtype ArgTransformer p sym args args' =+  ArgTransformer { applyArgTransformer :: (forall rtp l a.+    Ctx.Assignment (RegEntry sym) args ->+    OverrideSim p sym LLVM rtp l a (Ctx.Assignment (RegEntry sym) args')) }++newtype ValTransformer p sym tp tp' =+  ValTransformer { applyValTransformer :: (forall rtp l a.+    RegValue sym tp ->+    OverrideSim p sym LLVM rtp l a (RegValue sym tp')) }++transformLLVMArgs :: forall m p sym bak args args'.+  (IsSymBackend sym bak, Monad m, HasLLVMAnn sym) =>+  -- | This function name is only used in panic messages.+  FunctionName ->+  bak ->+  CtxRepr args' ->+  CtxRepr args ->+  m (ArgTransformer p sym args args')+transformLLVMArgs _fnName _ Ctx.Empty Ctx.Empty =+  return (ArgTransformer (\_ -> return Ctx.Empty))+transformLLVMArgs fnName bak (rest' Ctx.:> tp') (rest Ctx.:> tp) = do+  return (ArgTransformer+           (\(xs Ctx.:> x) ->+              do (ValTransformer f)  <- transformLLVMRet fnName bak tp tp'+                 (ArgTransformer fs) <- transformLLVMArgs fnName bak rest' rest+                 xs' <- fs xs+                 x'  <- RegEntry tp' <$> f (regValue x)+                 pure (xs' Ctx.:> x')))+transformLLVMArgs fnName _ _ _ =+  panic "Intrinsics.transformLLVMArgs"+    [ "transformLLVMArgs: argument shape mismatch!"+    , "in function: " ++ Text.unpack (functionName fnName)+    ]++transformLLVMRet ::+  (IsSymBackend sym bak, Monad m, HasLLVMAnn sym) =>+  -- | This function name is only used in panic messages.+  FunctionName ->+  bak ->+  TypeRepr ret  ->+  TypeRepr ret' ->+  m (ValTransformer p sym ret ret')+transformLLVMRet _fnName bak (BVRepr w) (LLVMPointerRepr w')+  | Just Refl <- testEquality w w'+  = return (ValTransformer (liftIO . llvmPointer_bv (backendGetSym bak)))+transformLLVMRet _fnName bak (LLVMPointerRepr w) (BVRepr w')+  | Just Refl <- testEquality w w'+  = return (ValTransformer (liftIO . projectLLVM_bv bak))+transformLLVMRet fnName bak (VectorRepr tp) (VectorRepr tp')+  = do ValTransformer f <- transformLLVMRet fnName bak tp tp'+       return (ValTransformer (traverse f))+transformLLVMRet fnName bak (StructRepr ctx) (StructRepr ctx')+  = do ArgTransformer tf <- transformLLVMArgs fnName bak ctx' ctx+       return (ValTransformer (\vals ->+          let vals' = Ctx.zipWith (\tp (RV v) -> RegEntry tp v) ctx vals in+          fmapFC (\x -> RV (regValue x)) <$> tf vals'))++transformLLVMRet _fnName _bak ret ret'+  | Just Refl <- testEquality ret ret'+  = return (ValTransformer return)+transformLLVMRet fnName _bak ret ret'+  = panic "Intrinsics.transformLLVMRet"+      [ "Cannot transform types"+      , "*** Source type: " ++ show ret+      , "*** Target type: " ++ show ret'+      , "in function: " ++ Text.unpack (functionName fnName)+      ]++-- | Do some pipe-fitting to match a Crucible override function into the shape+--   expected by the LLVM calling convention.  This basically just coerces+--   between values of @BVType w@ and values of @LLVMPointerType w@.+build_llvm_override ::+  HasLLVMAnn sym =>+  FunctionName ->+  CtxRepr args ->+  TypeRepr ret ->+  CtxRepr args' ->+  TypeRepr ret' ->+  (forall bak rtp' l' a'. IsSymBackend sym bak =>+   bak ->+   Ctx.Assignment (RegEntry sym) args ->+   OverrideSim p sym LLVM rtp' l' a' (RegValue sym ret)) ->+  OverrideSim p sym LLVM rtp l a (Override p sym LLVM args' ret')+build_llvm_override fnm args ret args' ret' llvmOverride =+  ovrWithBackend $ \bak ->+  do fargs <- transformLLVMArgs fnm bak args args'+     fret  <- transformLLVMRet fnm bak ret  ret'+     return $ mkOverride' fnm ret' $+            do RegMap xs <- getOverrideArgs+               ovrWithBackend $ \bak' ->+                 applyValTransformer fret =<< llvmOverride bak' =<< applyArgTransformer fargs xs++polymorphic1_llvm_override :: forall p sym arch wptr l a rtp.+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  String ->+  (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) ->+  OverrideTemplate p sym arch rtp l a+polymorphic1_llvm_override prefix fn =+  OverrideTemplate (PrefixMatch prefix) (register_1arg_polymorphic_override prefix fn)++register_1arg_polymorphic_override :: forall p sym arch wptr l a rtp.+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  String ->+  (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) ->+  RegOverrideM p sym arch rtp l a ()+register_1arg_polymorphic_override prefix overrideFn =+  do (L.Declare{ L.decName = L.Symbol nm },_,_) <- ask+     case List.stripPrefix prefix nm of+       Just ('.':'i': (readDec -> (sz,[]):_))+         | Some w <- mkNatRepr sz+         , Just LeqProof <- isPosNat w+         -> case overrideFn w of SomeLLVMOverride ovr -> register_llvm_override ovr+       _ -> empty++basic_llvm_override :: forall p args ret sym arch wptr l a rtp.+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  LLVMOverride p sym args ret ->+  OverrideTemplate p sym arch rtp l a+basic_llvm_override ovr = OverrideTemplate (ExactMatch nm) (register_llvm_override ovr)+ where L.Symbol nm = L.decName (llvmOverride_declare ovr)+++-- | Check that the requested declaration matches the provided declaration. In+-- this context, \"matching\" means that both declarations have identical names,+-- as well as equal argument and result types. When checking types for equality,+-- we consider opaque pointer types to be equal to non-opaque pointer types so+-- that we do not have to define quite so many overrides with different+-- combinations of pointer types.+isMatchingDeclaration ::+  L.Declare {- ^ Requested declaration -} ->+  L.Declare {- ^ Provided declaration for intrinsic -} ->+  Bool+isMatchingDeclaration requested provided = and+  [ L.decName requested == L.decName provided+  , matchingArgList (L.decArgs requested) (L.decArgs provided)+  , L.decRetType requested `L.eqTypeModuloOpaquePtrs` L.decRetType provided+  -- TODO? do we need to pay attention to various attributes?+  ]++ where+ matchingArgList [] [] = True+ matchingArgList [] _  = L.decVarArgs requested+ matchingArgList _  [] = L.decVarArgs provided+ matchingArgList (x:xs) (y:ys) = x `L.eqTypeModuloOpaquePtrs` y && matchingArgList xs ys++register_llvm_override :: forall p args ret sym arch wptr l a rtp.+  (IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym) =>+  LLVMOverride p sym args ret ->+  RegOverrideM p sym arch rtp l a ()+register_llvm_override llvmOverride = do+  (requestedDecl,_,llvmctx) <- ask+  let decl = llvmOverride_declare llvmOverride+  if not (isMatchingDeclaration requestedDecl decl) then+    do when (L.decName requestedDecl == L.decName decl) $+         do logFn <- lift $ lift $ getLogFunction+            liftIO $ logFn 3 $ unlines+              [ "Mismatched declaration signatures"+              , " *** requested: " ++ show requestedDecl+              , " *** found: "     ++ show decl+              , ""+              ]+       empty+  else lift (lift (do_register_llvm_override llvmctx llvmOverride))++-- | Bind a function handle, and also bind the function to the global function+-- allocation in the LLVM memory.+bind_llvm_handle ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  LLVMContext arch ->+  L.Symbol ->+  FnHandle args ret ->+  FnState p sym LLVM args ret ->+  OverrideSim p sym LLVM rtp l a ()+bind_llvm_handle llvmCtx nm hdl impl = do+  let mvar = llvmMemVar llvmCtx+  bindFnHandle hdl impl+  mem <- readGlobal mvar+  mem' <- ovrWithBackend $ \bak -> liftIO $ bindLLVMFunPtr bak nm hdl mem+  writeGlobal mvar mem'++-- | Low-level function to register LLVM functions.+--+-- Creates and binds a function handle, and also binds the function to the+-- global function allocation in the LLVM memory.+bind_llvm_func ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  LLVMContext arch ->+  L.Symbol ->+  Ctx.Assignment TypeRepr args ->+  TypeRepr ret ->+  FnState p sym LLVM args ret ->+  OverrideSim p sym LLVM rtp l a ()+bind_llvm_func llvmCtx nm args ret impl = do+  let L.Symbol strNm = nm+  let fnm  = functionNameFromText (Text.pack strNm)+  ctx <- use stateContext+  let ha = simHandleAllocator ctx+  h <- liftIO $ mkHandle' ha fnm args ret+  bind_llvm_handle llvmCtx nm h impl++-- | Low-level function to register LLVM overrides.+--+-- Type-checks the LLVM override against the 'L.Declare' it contains, adapting+-- its arguments and return values as necessary. Then creates and binds+-- a function handle, and also binds the function to the global function+-- allocation in the LLVM memory.+--+-- Useful when you don\'t have access to a full LLVM AST, e.g., when parsing+-- Crucible CFGs written in crucible-syntax. For more usual cases, use+-- 'Lang.Crucible.LLVM.Intrinsics.register_llvm_overrides'.+do_register_llvm_override :: forall p args ret sym arch wptr l a rtp.+  (IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym) =>+  LLVMContext arch ->+  LLVMOverride p sym args ret ->+  OverrideSim p sym LLVM rtp l a ()+do_register_llvm_override llvmctx llvmOverride = do+  let decl = llvmOverride_declare llvmOverride+  let (L.Symbol str_nm) = L.decName decl+  let fnm  = functionNameFromText (Text.pack str_nm)++  let mvar = llvmMemVar llvmctx+  let overrideArgs = llvmOverride_args llvmOverride+  let overrideRet  = llvmOverride_ret llvmOverride++  let ?lc = llvmctx^.llvmTypeCtx++  llvmDeclToFunHandleRepr' decl $ \args ret -> do+    o <- build_llvm_override fnm overrideArgs overrideRet args ret+           (\bak asgn -> llvmOverride_def llvmOverride mvar bak asgn)+    bind_llvm_func llvmctx (L.decName decl) args ret (UseOverride o)++-- | Create an allocation for an override and register it.+--+-- Useful when registering an override for a function in an LLVM memory that+-- wasn't initialized with the functions in "Lang.Crucible.LLVM.Globals", e.g.,+-- when parsing Crucible CFGs written in crucible-syntax. For more usual cases,+-- use 'Lang.Crucible.LLVM.Intrinsics.register_llvm_overrides'.+--+-- c.f. 'Lang.Crucible.LLVM.Globals.allocLLVMFunPtr'+alloc_and_register_override ::+  (IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym, ?memOpts :: MemOptions) =>+  bak ->+  LLVMContext arch ->+  LLVMOverride p sym args ret ->+  -- | Aliases+  [L.Symbol] ->+  OverrideSim p sym LLVM rtp l a ()+alloc_and_register_override bak llvmctx llvmOverride aliases = do+  let L.Declare { L.decName = symb@(L.Symbol nm) } = llvmOverride_declare llvmOverride+  let mvar = llvmMemVar llvmctx+  mem <- readGlobal mvar+  (_ptr, mem') <- liftIO (registerFunPtr bak mem nm symb aliases)+  writeGlobal mvar mem'+  do_register_llvm_override llvmctx llvmOverride
+ src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs view
@@ -0,0 +1,1573 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.LLVM+-- Description      : Override definitions for LLVM intrinsic and basic+--                    library functions+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.LLVM where++import           GHC.TypeNats (KnownNat)+import           Control.Lens hiding (op, (:>), Empty)+import           Control.Monad (foldM, unless)+import           Control.Monad.IO.Class (MonadIO(..))+import           Data.Bits ((.&.))+import qualified Data.Vector as V+import qualified Text.LLVM.AST as L++import qualified Data.BitVector.Sized as BV+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.Context ( pattern (:>), pattern Empty )++import           What4.Interface+import           What4.InterpretedFloatingPoint+import qualified What4.SpecialFunctions as W4++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common (GlobalVar)+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError (SimErrorReason(AssertFailureSimError))++import           Lang.Crucible.LLVM.Bytes (Bytes(..))+import           Lang.Crucible.LLVM.DataLayout (noAlignment)+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.QQ( llvmOvr )++import           Lang.Crucible.LLVM.Intrinsics.Common+import qualified Lang.Crucible.LLVM.Intrinsics.Libc as Libc++------------------------------------------------------------------------+-- ** Declarations++-- | This intrinsic is currently a no-op.+--+-- We might want to support this in the future to catch undefined memory+-- accesses.+--+-- <https://llvm.org/docs/LangRef.html#llvm-lifetime-start-intrinsic LLVM docs>+llvmLifetimeStartOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType+llvmLifetimeStartOverride =+  [llvmOvr| void @llvm.lifetime.start( i64, i8* ) |]+  (\_ops _sym _args -> return ())++-- | See comment on 'llvmLifetimeStartOverride'+--+-- <https://llvm.org/docs/LangRef.html#llvm-lifetime-end-intrinsic LLVM docs>+llvmLifetimeEndOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType+llvmLifetimeEndOverride =+  [llvmOvr| void @llvm.lifetime.end( i64, i8* ) |]+  (\_ops _sym _args -> return ())++-- | This is a no-op.+--+-- The language reference doesn't mention the use of this intrinsic.+llvmLifetimeOverrideOverload+  :: forall width sym wptr p+   . ( 1 <= width, KnownNat width+     , IsSymInterface sym, HasPtrWidth wptr)+  => String -- ^ "start" or "end"+  -> NatRepr width+  -> LLVMOverride p sym+        (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr)+        UnitType -- It appears in practice that this is always void+llvmLifetimeOverrideOverload startOrEnd w =+  let nm = L.Symbol ("llvm.lifetime." ++ startOrEnd ++ ".p0i" ++ show (widthVal w)) in+    [llvmOvr| void $nm ( i64, #w * ) |]+    (\_ops _sym _args -> return ())++-- | Like 'llvmLifetimeOverrideOverload', but with an opaque pointer type.+llvmLifetimeOverrideOverload_opaque+  :: forall sym wptr p+   . (IsSymInterface sym, HasPtrWidth wptr)+  => String -- ^ "start" or "end"+  -> LLVMOverride p sym+        (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr)+        UnitType -- It appears in practice that this is always void+llvmLifetimeOverrideOverload_opaque startOrEnd =+  let nm = L.Symbol ("llvm.lifetime." ++ startOrEnd ++ ".p0") in+    [llvmOvr| void $nm ( i64, ptr ) |]+    (\_ops _sym _args -> return ())++-- | This intrinsic is currently a no-op.+--+-- We might want to support this in the future to catch undefined memory+-- writes.+--+-- <https://llvm.org/docs/LangRef.html#llvm-invariant-start-intrinsic LLVM docs>+llvmInvariantStartOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => NatRepr width+  -> LLVMOverride p sym+       (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr)+       (LLVMPointerType wptr)+llvmInvariantStartOverride w =+  let nm = L.Symbol ("llvm.invariant.start.p0i" ++ show (widthVal w)) in+    [llvmOvr| {}* $nm ( i64, #w * ) |]+    (\_ops bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth))++-- | Like 'llvmInvariantStartOverride', but with an opaque pointer type.+llvmInvariantStartOverride_opaque+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym+       (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr)+       (LLVMPointerType wptr)+llvmInvariantStartOverride_opaque =+  let nm = L.Symbol "llvm.invariant.start.p0" in+    [llvmOvr| {}* $nm ( i64, ptr ) |]+    (\_ops bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth))++-- | See comment on 'llvmInvariantStartOverride'.+llvmInvariantEndOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => NatRepr width+  -> LLVMOverride p sym+       (EmptyCtx ::> LLVMPointerType wptr ::> BVType 64 ::> LLVMPointerType wptr)+       UnitType+llvmInvariantEndOverride w =+  let nm = L.Symbol ("llvm.invariant.end.p0i" ++ show (widthVal w)) in+    [llvmOvr| void $nm ( {}*, i64, #w * ) |]+    (\_ops _bak _args -> return ())++-- | See comment on 'llvmInvariantStartOverride_opaque'.+llvmInvariantEndOverride_opaque+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym+       (EmptyCtx ::> LLVMPointerType wptr ::> BVType 64 ::> LLVMPointerType wptr)+       UnitType+llvmInvariantEndOverride_opaque =+  let nm = L.Symbol "llvm.invariant.end.p0" in+    [llvmOvr| void $nm ( {}*, i64, ptr ) |]+    (\_ops _bak _args -> return ())++-- | This instruction is a hint to optimizers, it isn't really useful for us.+--+-- Its runtime behavior of that of Haskell\'s 'const': just ignore the second+-- argument.+llvmExpectOverride+  :: (IsSymInterface sym, 1 <= width)+  => NatRepr width+  -> LLVMOverride p sym+       (EmptyCtx ::> BVType width ::> BVType width)+       (BVType width)+llvmExpectOverride w =+  let nm = L.Symbol ("llvm.expect.i" ++ show (widthVal w)) in+    [llvmOvr| #w $nm ( #w, #w ) |]+    (\_ops _bak args ->+        Ctx.uncurryAssignment (\val _ -> pure (regValue val)) args)++-- | This intrinsic asserts that its argument is equal to 1.+--+-- We could have this generate a verification condition, but that would catch+-- clang compiler bugs (or Crucible bugs) more than user code bugs.+llvmAssumeOverride+  :: (IsSymInterface sym)+  => LLVMOverride p sym (EmptyCtx ::> BVType 1) UnitType+llvmAssumeOverride =+   [llvmOvr| void @llvm.assume ( i1 ) |]+   (\_ops _bak _args -> return ())++-- | This intrinsic is sometimes inserted by clang, and we interpret it+--   as an assertion failure, similar to calling @abort()@.+llvmTrapOverride+  :: (IsSymInterface sym)+  => LLVMOverride p sym EmptyCtx UnitType+llvmTrapOverride =+  [llvmOvr| void @llvm.trap() |]+  (\_ops bak _args -> liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.trap() called" "")++-- | This is like @llvm.trap()@, but with an argument indicating which sort of+-- undefined behavior was trapped. The argument acts as an index into+-- <https://github.com/llvm/llvm-project/blob/650bbc56203c947bb85176c40ca9c7c7a91c3c57/clang/lib/CodeGen/CodeGenFunction.h#L118-L143 this list>.+-- Ideally, we would do something intelligent with this argument—see #368.+llvmUBSanTrapOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym (EmptyCtx ::> BVType 8) UnitType+llvmUBSanTrapOverride =+  [llvmOvr| void @llvm.ubsantrap( i8 ) |]+  (\_ops bak _args -> liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.ubsantrap() called" "")++llvmStacksave+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym EmptyCtx (LLVMPointerType wptr)+llvmStacksave =+  [llvmOvr| i8* @llvm.stacksave() |]+  (\_memOps bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth))++llvmStackrestore+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) UnitType+llvmStackrestore =+  [llvmOvr| void @llvm.stackrestore( i8* ) |]+  (\_memOps _bak _args -> return ())++llvmMemmoveOverride_8_8_32+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 32 ::> BVType 32 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_32 =+  [llvmOvr| void @llvm.memmove.p0i8.p0i8.i32( i8*, i8*, i32, i32, i1 ) |]+  (\memOps bak args ->+     Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove bak memOps dst src len v) args)++llvmMemmoveOverride_8_8_32_noalign+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 32 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_32_noalign =+  [llvmOvr| void @llvm.memmove.p0i8.p0i8.i32( i8*, i8*, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args)++llvmMemmoveOverride_8_8_32_noalign_opaque+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 32 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_32_noalign_opaque =+  [llvmOvr| void @llvm.memmove.p0.p0.i32( ptr, ptr, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args)+++llvmMemmoveOverride_8_8_64+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 32 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_64 =+  [llvmOvr| void @llvm.memmove.p0i8.p0i8.i64( i8*, i8*, i64, i32, i1 ) |]+  (\memOps bak args ->+      Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove bak memOps dst src len v) args)++llvmMemmoveOverride_8_8_64_noalign+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_64_noalign =+  [llvmOvr| void @llvm.memmove.p0i8.p0i8.i64( i8*, i8*, i64, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args)++llvmMemmoveOverride_8_8_64_noalign_opaque+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 1)+         UnitType+llvmMemmoveOverride_8_8_64_noalign_opaque =+  [llvmOvr| void @llvm.memmove.p0.p0.i64( ptr, ptr, i64, i1 ) |]+  (\memOps bak args ->+      Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args)+++llvmMemsetOverride_8_64+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 64+                   ::> BVType 32+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_64 =+  [llvmOvr| void @llvm.memset.p0i8.i64( i8*, i8, i64, i32, i1 ) |]+  (\memOps bak args ->+    Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset bak memOps dst val len v) args)++llvmMemsetOverride_8_64_noalign+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 64+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_64_noalign =+  [llvmOvr| void @llvm.memset.p0i8.i64( i8*, i8, i64, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args)++llvmMemsetOverride_8_64_noalign_opaque+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 64+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_64_noalign_opaque =+  [llvmOvr| void @llvm.memset.p0.i64( ptr, i8, i64, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args)+++llvmMemsetOverride_8_32+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 32+                   ::> BVType 32+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_32 =+  [llvmOvr| void @llvm.memset.p0i8.i32( i8*, i8, i32, i32, i1 ) |]+  (\memOps bak args ->+    Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset bak memOps dst val len v) args)++llvmMemsetOverride_8_32_noalign+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 32+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_32_noalign =+  [llvmOvr| void @llvm.memset.p0i8.i32( i8*, i8, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args)++llvmMemsetOverride_8_32_noalign_opaque+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType  8+                   ::> BVType 32+                   ::> BVType 1)+         UnitType+llvmMemsetOverride_8_32_noalign_opaque =+  [llvmOvr| void @llvm.memset.p0.i32( ptr, i8, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args)+++llvmMemcpyOverride_8_8_32+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+          (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                    ::> BVType 32 ::> BVType 32 ::> BVType 1)+          UnitType+llvmMemcpyOverride_8_8_32 =+  [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i32( i8*, i8*, i32, i32, i1 ) |]+  (\memOps bak args ->+    Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy bak memOps dst src len v) args)++llvmMemcpyOverride_8_8_32_noalign+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+          (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                    ::> BVType 32 ::> BVType 1)+          UnitType+llvmMemcpyOverride_8_8_32_noalign =+  [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i32( i8*, i8*, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args)++llvmMemcpyOverride_8_8_32_noalign_opaque+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+          (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                    ::> BVType 32 ::> BVType 1)+          UnitType+llvmMemcpyOverride_8_8_32_noalign_opaque =+  [llvmOvr| void @llvm.memcpy.p0.p0.i32( ptr, ptr, i32, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args)+++llvmMemcpyOverride_8_8_64+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 32 ::> BVType 1)+         UnitType+llvmMemcpyOverride_8_8_64 =+  [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i64( i8*, i8*, i64, i32, i1 ) |]+  (\memOps bak args ->+    Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy bak memOps dst src len v) args)++llvmMemcpyOverride_8_8_64_noalign+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 1)+         UnitType+llvmMemcpyOverride_8_8_64_noalign =+  [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i64( i8*, i8*, i64, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args)++llvmMemcpyOverride_8_8_64_noalign_opaque+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr+                   ::> BVType 64 ::> BVType 1)+         UnitType+llvmMemcpyOverride_8_8_64_noalign_opaque =+  [llvmOvr| void @llvm.memcpy.p0.p0.i64( ptr, ptr, i64, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args)+++llvmObjectsizeOverride_32+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 32)+llvmObjectsizeOverride_32 =+  [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize bak memOps knownNat) args)++llvmObjectsizeOverride_32_null+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 32)+llvmObjectsizeOverride_32_null =+  [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null bak memOps knownNat) args)++llvmObjectsizeOverride_32_null_dynamic+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 32)+llvmObjectsizeOverride_32_null_dynamic =+  [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args)++llvmObjectsizeOverride_32_null_dynamic_opaque+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 32)+llvmObjectsizeOverride_32_null_dynamic_opaque =+  [llvmOvr| i32 @llvm.objectsize.i32.p0( ptr, i1, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args)++llvmObjectsizeOverride_64+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 64)+llvmObjectsizeOverride_64 =+  [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize bak memOps knownNat) args)++llvmObjectsizeOverride_64_null+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 64)+llvmObjectsizeOverride_64_null =+  [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null bak memOps knownNat) args)++llvmObjectsizeOverride_64_null_dynamic+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 64)+llvmObjectsizeOverride_64_null_dynamic =+  [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args)++llvmObjectsizeOverride_64_null_dynamic_opaque+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 64)+llvmObjectsizeOverride_64_null_dynamic_opaque =+  [llvmOvr| i64 @llvm.objectsize.i64.p0( ptr, i1, i1, i1 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args)++-- | This instruction is a hint to code generators, which means that it is a+-- no-op for us.+--+-- <https://releases.llvm.org/12.0.0/docs/LangRef.html#llvm-prefetch-intrinsic LLVM docs>+llvmPrefetchOverride ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  LLVMOverride p sym+    (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32)+    UnitType+llvmPrefetchOverride =+  [llvmOvr| void @llvm.prefetch.p0i8( i8*, i32, i32, i32 ) |]+  (\_memOps _bak _args -> pure ())++-- | Like 'llvmPrefetchOverride', but with an opaque pointer type.+llvmPrefetchOverride_opaque ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  LLVMOverride p sym+    (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32)+    UnitType+llvmPrefetchOverride_opaque =+  [llvmOvr| void @llvm.prefetch.p0( ptr, i32, i32, i32 ) |]+  (\_memOps _bak _args -> pure ())++-- | This instruction is a hint to code generators, which means that it is a+-- no-op for us.+--+-- See also 'llvmPrefetchOverride'. This version exists for compatibility with+-- pre-10 versions of LLVM, where llvm.prefetch always assumed that the first+-- argument resides in address space 0.+--+-- <https://releases.llvm.org/12.0.0/docs/LangRef.html#llvm-prefetch-intrinsic LLVM docs>+llvmPrefetchOverride_preLLVM10 ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  LLVMOverride p sym+    (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32)+    UnitType+llvmPrefetchOverride_preLLVM10 =+  [llvmOvr| void @llvm.prefetch( i8*, i32, i32, i32 ) |]+  (\_memOps _bak _args -> pure ())++llvmFshl ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+    (EmptyCtx ::> BVType w ::> BVType w ::> BVType w)+    (BVType w)+llvmFshl w =+ let nm = L.Symbol ("llvm.fshl.i" ++ show (natValue w)) in+ [llvmOvr| #w $nm ( #w, #w, #w ) |]+ (\_memOps bak args -> Ctx.uncurryAssignment (callFshl bak w) args)++llvmFshr ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+    (EmptyCtx ::> BVType w ::> BVType w ::> BVType w)+    (BVType w)+llvmFshr w =+ let nm = L.Symbol ("llvm.fshr.i" ++ show (natValue w)) in+ [llvmOvr| #w $nm ( #w, #w, #w ) |]+ (\_memOps bak args -> Ctx.uncurryAssignment (callFshr bak w) args)++llvmSaddWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmSaddWithOverflow w =+  let nm = L.Symbol ("llvm.sadd.with.overflow.i" ++ show (natValue w)) in+  [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callSaddWithOverflow bak memOps) args)++llvmUaddWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmUaddWithOverflow w =+  let nm = L.Symbol ("llvm.uadd.with.overflow.i" ++ show (natValue w)) in+    [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callUaddWithOverflow bak memOps) args)+++llvmSsubWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmSsubWithOverflow w =+  let nm = L.Symbol ("llvm.ssub.with.overflow.i" ++ show (natValue w)) in+    [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callSsubWithOverflow bak memOps) args)+++llvmUsubWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmUsubWithOverflow w =+  let nm = L.Symbol ("llvm.usub.with.overflow.i" ++ show (natValue w)) in+    [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callUsubWithOverflow bak memOps) args)++llvmSmulWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmSmulWithOverflow w =+  let nm = L.Symbol ("llvm.smul.with.overflow.i" ++ show (natValue w)) in+    [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callSmulWithOverflow bak memOps) args)++llvmUmulWithOverflow+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType w)+         (StructType (EmptyCtx ::> BVType w ::> BVType 1))+llvmUmulWithOverflow w =+  let nm = L.Symbol ("llvm.umul.with.overflow.i" ++ show (natValue w)) in+  [llvmOvr| { #w, i1 } $nm ( #w, #w ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callUmulWithOverflow bak memOps) args)++llvmUmax ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+     (EmptyCtx ::> BVType w ::> BVType w)+     (BVType w)+llvmUmax w =+  let nm = L.Symbol ("llvm.umax.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callUmax bak memOps) args)++llvmUmin ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+     (EmptyCtx ::> BVType w ::> BVType w)+     (BVType w)+llvmUmin w =+  let nm = L.Symbol ("llvm.umin.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callUmin bak memOps) args)++llvmSmax ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+     (EmptyCtx ::> BVType w ::> BVType w)+     (BVType w)+llvmSmax w =+  let nm = L.Symbol ("llvm.smax.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callSmax bak memOps) args)++llvmSmin ::+  (1 <= w, IsSymInterface sym) =>+  NatRepr w ->+  LLVMOverride p sym+     (EmptyCtx ::> BVType w ::> BVType w)+     (BVType w)+llvmSmin w =+  let nm = L.Symbol ("llvm.smin.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w, #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callSmin bak memOps) args)++llvmCtlz+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w ->+     LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType 1)+         (BVType w)+llvmCtlz w =+  let nm = L.Symbol ("llvm.ctlz.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm ( #w, i1 ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callCtlz bak memOps) args)++llvmCttz+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w+  -> LLVMOverride p sym+         (EmptyCtx ::> BVType w ::> BVType 1)+         (BVType w)+llvmCttz w =+  let nm = L.Symbol ("llvm.cttz.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm ( #w, i1 ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callCttz bak memOps) args)++llvmCtpop+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w+  -> LLVMOverride p sym+         (EmptyCtx ::> BVType w)+         (BVType w)+llvmCtpop w =+  let nm = L.Symbol ("llvm.ctpop.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callCtpop bak memOps) args)++llvmBitreverse+  :: (1 <= w, IsSymInterface sym)+  => NatRepr w+  -> LLVMOverride p sym+         (EmptyCtx ::> BVType w)+         (BVType w)+llvmBitreverse w =+  let nm = L.Symbol ("llvm.bitreverse.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w ) |]+    (\memOps bak args -> Ctx.uncurryAssignment (callBitreverse bak memOps) args)++-- | <https://llvm.org/docs/LangRef.html#llvm-bswap-intrinsics LLVM docs>+llvmBSwapOverride+  :: forall width sym p+   . ( 1 <= width, IsSymInterface sym)+  => NatRepr width+  -> LLVMOverride p sym+         (EmptyCtx ::> BVType (width * 8))+         (BVType (width * 8))+llvmBSwapOverride widthRepr =+  let width8 = natMultiply widthRepr (knownNat @8)+      nm = L.Symbol ("llvm.bswap.i" ++ show (widthVal width8))+  in+    case mulComm widthRepr (knownNat @8) of { Refl ->+    case leqMulMono (knownNat @8) widthRepr :: LeqProof width (width * 8) of { LeqProof ->+    case leqTrans (LeqProof :: LeqProof 1 width)+                  (LeqProof :: LeqProof width (width * 8)) of { LeqProof ->+        -- From the LLVM docs:+        -- declare i16 @llvm.bswap.i16(i16 <id>)+        [llvmOvr| #width8 $nm( #width8 ) |]+        (\_ bak args -> Ctx.uncurryAssignment (Libc.callBSwap bak widthRepr) args)+    }}}++llvmAbsOverride ::+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  NatRepr w ->+  LLVMOverride p sym+     (EmptyCtx ::> BVType w ::> BVType 1)+     (BVType w)+llvmAbsOverride w =+  let nm = L.Symbol ("llvm.abs.i" ++ show (natValue w)) in+    [llvmOvr| #w $nm( #w, i1 ) |]+    (\mvar bak args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (Libc.callLLVMAbs bak callStack w) args)++llvmCopysignOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCopysignOverride_F32 =+  [llvmOvr| float @llvm.copysign.f32( float, float ) |]+  (\_memOpts bak args -> Ctx.uncurryAssignment (callCopysign bak) args)++llvmCopysignOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCopysignOverride_F64 =+  [llvmOvr| double @llvm.copysign.f64( double, double ) |]+  (\_memOpts bak args -> Ctx.uncurryAssignment (callCopysign bak) args)+++llvmFabsF32+  :: forall sym p+   . ( IsSymInterface sym)+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType SingleFloat)+        (FloatType SingleFloat)+llvmFabsF32 =+  [llvmOvr| float @llvm.fabs.f32( float ) |]+  (\_memOps bak (Empty :> (regValue -> x)) -> liftIO (iFloatAbs @_ @SingleFloat (backendGetSym bak) x))+++llvmFabsF64+  :: forall sym p+   . ( IsSymInterface sym)+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType DoubleFloat)+        (FloatType DoubleFloat)+llvmFabsF64 =+  [llvmOvr| double @llvm.fabs.f64( double ) |]+  (\_memOps bak (Empty :> (regValue -> x)) -> liftIO (iFloatAbs @_ @DoubleFloat (backendGetSym bak) x))++llvmCeilOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCeilOverride_F32 =+  [llvmOvr| float @llvm.ceil.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callCeil bak) args)++llvmCeilOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCeilOverride_F64 =+  [llvmOvr| double @llvm.ceil.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callCeil bak) args)++llvmFloorOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmFloorOverride_F32 =+  [llvmOvr| float @llvm.floor.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFloor bak) args)++llvmFloorOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmFloorOverride_F64 =+  [llvmOvr| double @llvm.floor.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFloor bak) args)++llvmSqrtOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSqrtOverride_F32 =+  [llvmOvr| float @llvm.sqrt.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSqrt bak) args)++llvmSqrtOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSqrtOverride_F64 =+  [llvmOvr| double @llvm.sqrt.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSqrt bak) args)++llvmSinOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinOverride_F32 =+  [llvmOvr| float @llvm.sin.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Sin) args)++llvmSinOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinOverride_F64 =+  [llvmOvr| double @llvm.sin.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Sin) args)++llvmCosOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCosOverride_F32 =+  [llvmOvr| float @llvm.cos.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Cos) args)++llvmCosOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCosOverride_F64 =+  [llvmOvr| double @llvm.cos.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Cos) args)++llvmPowOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmPowOverride_F32 =+  [llvmOvr| float @llvm.pow.f32( float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 bak W4.Pow) args)++llvmPowOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmPowOverride_F64 =+  [llvmOvr| double @llvm.pow.f64( double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 bak W4.Pow) args)++llvmExpOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExpOverride_F32 =+  [llvmOvr| float @llvm.exp.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp) args)++llvmExpOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExpOverride_F64 =+  [llvmOvr| double @llvm.exp.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp) args)++llvmLogOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLogOverride_F32 =+  [llvmOvr| float @llvm.log.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log) args)++llvmLogOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLogOverride_F64 =+  [llvmOvr| double @llvm.log.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log) args)++llvmExp2Override_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExp2Override_F32 =+  [llvmOvr| float @llvm.exp2.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp2) args)++llvmExp2Override_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExp2Override_F64 =+  [llvmOvr| double @llvm.exp2.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp2) args)++llvmLog2Override_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog2Override_F32 =+  [llvmOvr| float @llvm.log2.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log2) args)++llvmLog2Override_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog2Override_F64 =+  [llvmOvr| double @llvm.log2.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log2) args)++llvmLog10Override_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog10Override_F32 =+  [llvmOvr| float @llvm.log10.f32( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log10) args)++llvmLog10Override_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog10Override_F64 =+  [llvmOvr| double @llvm.log10.f64( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log10) args)++llvmIsFpclassOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat+               ::> BVType 32)+     (BVType 1)+llvmIsFpclassOverride_F32 =+  [llvmOvr| i1 @llvm.is.fpclass.f32( float, i32 ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callIsFpclass bak) args)++llvmIsFpclassOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat+               ::> BVType 32)+     (BVType 1)+llvmIsFpclassOverride_F64 =+  [llvmOvr| i1 @llvm.is.fpclass.f64( double, i32 ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callIsFpclass bak) args)++llvmFmaOverride_F32 ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType SingleFloat+                  ::> FloatType SingleFloat+                  ::> FloatType SingleFloat)+        (FloatType SingleFloat)+llvmFmaOverride_F32 =+  [llvmOvr| float @llvm.fma.f32( float, float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args)++llvmFmaOverride_F64 ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat)+        (FloatType DoubleFloat)+llvmFmaOverride_F64 =+  [llvmOvr| double @llvm.fma.f64( double, double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args)++llvmFmuladdOverride_F32 ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType SingleFloat+                  ::> FloatType SingleFloat+                  ::> FloatType SingleFloat)+        (FloatType SingleFloat)+llvmFmuladdOverride_F32 =+  [llvmOvr| float @llvm.fmuladd.f32( float, float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args)++llvmFmuladdOverride_F64 ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat)+        (FloatType DoubleFloat)+llvmFmuladdOverride_F64 =+  [llvmOvr| double @llvm.fmuladd.f64( double, double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args)+++llvmX86_pclmulqdq+--declare <2 x i64> @llvm.x86.pclmulqdq(<2 x i64>, <2 x i64>, i8) #1+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> VectorType (BVType 64)+                   ::> VectorType (BVType 64)+                   ::> BVType 8)+         (VectorType (BVType 64))+llvmX86_pclmulqdq =+  [llvmOvr| <2 x i64> @llvm.x86.pclmulqdq(<2 x i64>, <2 x i64>, i8) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callX86_pclmulqdq bak memOps) args)+++llvmX86_SSE2_storeu_dq+  :: ( IsSymInterface sym+     , HasLLVMAnn sym+     , HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> VectorType (BVType 8))+         UnitType+llvmX86_SSE2_storeu_dq =+  [llvmOvr| void @llvm.x86.sse2.storeu.dq( i8*, <16 x i8> ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callStoreudq bak memOps) args)++------------------------------------------------------------------------+-- ** Implementations++callX86_pclmulqdq :: forall p sym bak ext wptr r args ret.+  (IsSymBackend sym bak, HasPtrWidth wptr) =>+  bak ->+  GlobalVar Mem ->+  RegEntry sym (VectorType (BVType 64)) ->+  RegEntry sym (VectorType (BVType 64)) ->+  RegEntry sym (BVType 8) ->+  OverrideSim p sym ext r args ret (RegValue sym (VectorType (BVType 64)))+callX86_pclmulqdq bak _mvar+  (regValue -> xs)+  (regValue -> ys)+  (regValue -> imm) =+    do unless (V.length xs == 2) $+          liftIO $ addFailedAssertion bak $ AssertFailureSimError+           ("Vector length mismatch in llvm.x86.pclmulqdq intrinsic")+           (unwords ["Expected <2 x i64>, but got vector of length", show (V.length xs)])+       unless (V.length ys == 2) $+          liftIO $ addFailedAssertion bak $ AssertFailureSimError+           ("Vector length mismatch in llvm.x86.pclmulqdq intrinsic")+           (unwords ["Expected <2 x i64>, but got vector of length", show (V.length ys)])+       case BV.asUnsigned <$> asBV imm of+         Just byte ->+           do let xidx = if byte .&. 0x01 == 0 then 0 else 1+              let yidx = if byte .&. 0x10 == 0 then 0 else 1+              liftIO $ doPcmul (xs V.! xidx) (ys V.! yidx)+         _ ->+             liftIO $ addFailedAssertion bak $ AssertFailureSimError+                ("Illegal selector argument to llvm.x86.pclmulqdq")+                (unwords ["Expected concrete value but got", show (printSymExpr imm)])+  where+  sym = backendGetSym bak++  doPcmul :: SymBV sym 64 -> SymBV sym 64 -> IO (V.Vector (SymBV sym 64))+  doPcmul x y =+    do r <- carrylessMultiply sym x y+       lo <- bvTrunc sym (knownNat @64) r+       hi <- bvSelect sym (knownNat @64) (knownNat @64) r+       -- NB, little endian because X86+       return $ V.fromList [ lo, hi ]++callStoreudq+  :: ( IsSymBackend sym bak+     , HasLLVMAnn sym+     , HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (VectorType (BVType 8))+  -> OverrideSim p sym ext r args ret ()+callStoreudq bak mvar+  (regValue -> dest)+  (regValue -> vec) =+    do mem <- readGlobal mvar+       unless (V.length vec == 16) $+          liftIO $ addFailedAssertion bak $ AssertFailureSimError+           ("Vector length mismatch in stored_qu intrinsic.")+           (unwords ["Expected <16 x i8>, but got vector of length", show (V.length vec)])+       mem' <- liftIO $ doStore+                 bak+                 mem+                 dest+                 (VectorRepr (KnownBV @8))+                 (arrayType 16 (bitvectorType (Bytes 1)))+                 noAlignment+                 vec+       writeGlobal mvar mem'+++-- Excerpt from the LLVM documentation:+--+-- The llvm.objectsize intrinsic is designed to provide information to+-- the optimizers to determine at compile time whether a) an operation+-- (like memcpy) will overflow a buffer that corresponds to an object,+-- or b) that a runtime check for overflow isn’t necessary. An object+-- in this context means an allocation of a specific class, structure,+-- array, or other object.+--+-- The llvm.objectsize intrinsic takes two arguments. The first+-- argument is a pointer to or into the object. The second argument is+-- a boolean and determines whether llvm.objectsize returns 0 (if+-- true) or -1 (if false) when the object size is unknown. The second+-- argument only accepts constants.+--+-- The llvm.objectsize intrinsic is lowered to a constant representing+-- the size of the object concerned. If the size cannot be determined+-- at compile time, llvm.objectsize returns i32/i64 -1 or 0 (depending+-- on the min argument).+callObjectsize+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> NatRepr w+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callObjectsize bak _mvar w+  (regValue -> _ptr)+  (regValue -> flag) = liftIO $ do+    let sym = backendGetSym bak+    -- Ignore the pointer value, and just return the value for unknown, as+    -- defined by the documenatation.  If an `objectsize` invocation survives+    -- through compilation for us to see, that means the compiler could not+    -- determine the value.+    t <- bvIsNonzero sym flag+    z <- bvLit sym w (BV.zero w)+    n <- bvNotBits sym z -- NB: -1 is the boolean negation of zero+    bvIte sym t z n++callObjectsize_null+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> NatRepr w+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType 1)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callObjectsize_null bak mvar w ptr flag _nullUnknown = callObjectsize bak mvar w ptr flag++callObjectsize_null_dynamic+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> NatRepr w+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType 1)+  -> RegEntry sym (BVType 1)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callObjectsize_null_dynamic bak mvar w ptr flag _nullUnknown (regValue -> dynamic) =+  do let sym = backendGetSym bak+     liftIO $+       do notDynamic <- notPred sym =<< bvIsNonzero sym dynamic+          assert bak notDynamic (AssertFailureSimError "llvm.objectsize called with `dynamic` set to `true`" "")+     callObjectsize bak mvar w ptr flag++callCtlz+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callCtlz bak _mvar+  (regValue -> val)+  (regValue -> isZeroUndef) = liftIO $+    do let sym = backendGetSym bak+       isNonzero <- bvIsNonzero sym val+       zeroOK    <- notPred sym =<< bvIsNonzero sym isZeroUndef+       p <- orPred sym isNonzero zeroOK+       assert bak p (AssertFailureSimError "Ctlz called with disallowed zero value" "")+       bvCountLeadingZeros sym val++callFshl+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> NatRepr w+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callFshl bak w x y amt = liftIO $+  do LeqProof <- return (dblPosIsPos (leqProof (knownNat @1) w))+     Just LeqProof <- return (testLeq (addNat w (knownNat @1)) (addNat w w))+     let sym = backendGetSym bak++     -- concatenate the values together+     xy <- bvConcat sym (regValue x) (regValue y)++     -- The shift argument is treated as an unsigned amount modulo the element size of the arguments.+     m <- bvLit sym w (BV.width w)+     mamt <- bvUrem sym (regValue amt) m+     mamt' <- bvZext sym (addNat w w) mamt++     -- shift left, select high bits+     z <- bvShl sym xy mamt'+     bvSelect sym w w z++callFshr+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> NatRepr w+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callFshr bak w x y amt = liftIO $+  do LeqProof <- return (dblPosIsPos (leqProof (knownNat @1) w))+     LeqProof <- return (addPrefixIsLeq w w)+     Just LeqProof <- return (testLeq (addNat w (knownNat @1)) (addNat w w))+     let sym = backendGetSym bak++     -- concatenate the values together+     xy <- bvConcat sym (regValue x) (regValue y)++     -- The shift argument is treated as an unsigned amount modulo the element size of the arguments.+     m <- bvLit sym w (BV.width w)+     mamt <- bvUrem sym (regValue amt) m+     mamt' <- bvZext sym (addNat w w) mamt++     -- shift right, select low bits+     z <- bvLshr sym xy mamt'+     bvSelect sym (knownNat @0) w z++callSaddWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callSaddWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- addSignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callUaddWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callUaddWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- addUnsignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callUsubWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callUsubWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- subUnsignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callSsubWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callSsubWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- subSignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callSmulWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callSmulWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- mulSignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callUmulWithOverflow+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1)))+callUmulWithOverflow bak _mvar+  (regValue -> x)+  (regValue -> y) = liftIO $+    do let sym = backendGetSym bak+       (ov, z) <- mulUnsignedOF sym x y+       ov' <- predToBV sym ov (knownNat @1)+       return (Empty :> RV z :> RV ov')++callUmax+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callUmax bak _mvar (regValue -> x) (regValue -> y) = liftIO $+  do let sym = backendGetSym bak+     xGtY <- bvUgt sym x y+     bvIte sym xGtY x y++callUmin+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callUmin bak _mvar (regValue -> x) (regValue -> y) = liftIO $+  do let sym = backendGetSym bak+     xLtY <- bvUlt sym x y+     bvIte sym xLtY x y++callSmax+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callSmax bak _mvar (regValue -> x) (regValue -> y) = liftIO $+  do let sym = backendGetSym bak+     xGtY <- bvSgt sym x y+     bvIte sym xGtY x y++callSmin+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callSmin bak _mvar (regValue -> x) (regValue -> y) = liftIO $+  do let sym = backendGetSym bak+     xLtY <- bvSlt sym x y+     bvIte sym xLtY x y+++callCttz+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callCttz bak _mvar+  (regValue -> val)+  (regValue -> isZeroUndef) = liftIO $+    do let sym = backendGetSym bak+       isNonzero <- bvIsNonzero sym val+       zeroOK    <- notPred sym =<< bvIsNonzero sym isZeroUndef+       p <- orPred sym isNonzero zeroOK+       assert bak p (AssertFailureSimError "Cttz called with disallowed zero value" "")+       bvCountTrailingZeros sym val++callCtpop+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callCtpop bak _mvar+  (regValue -> val) = liftIO $ bvPopcount (backendGetSym bak) val++callBitreverse+  :: (1 <= w, IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType w)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callBitreverse bak _mvar+  (regValue -> val) = liftIO $ bvBitreverse (backendGetSym bak) val++-- | Strictly speaking, this doesn't quite conform to the C99 description of+-- @copysign@, since @copysign(NaN, -1.0)@ should return @NaN@ with a negative+-- sign bit. @libBF@ does not provide a way to distinguish between @NaN@ values+-- with different sign bits, however, so @copysign@ will always turn a @NaN@+-- argument into a positive, \"quiet\" @NaN@.+callCopysign ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak) =>+  bak ->+  RegEntry sym (FloatType fi) ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callCopysign bak+  (regValue -> x)+  (regValue -> y) = liftIO $ do+    let sym = backendGetSym bak+    xIsNeg    <- iFloatIsNeg @_ @fi sym x+    yIsNeg    <- iFloatIsNeg @_ @fi sym y+    signsSame <- eqPred sym xIsNeg yIsNeg+    xNegated  <- iFloatNeg @_ @fi sym x+    iFloatIte @_ @fi sym signsSame x xNegated++-- | An implementation of the @llvm.is.fpclass@ intrinsic. This essentially+-- combines several different floating-point checks (checking for @NaN@,+-- infinity, zero, etc.) into a single function. The second argument is a+-- bitmask that controls which properties to check of the first argument.+-- The different checks in the bitmask are described by the table here:+-- <https://llvm.org/docs/LangRef.html#id1566>+--+-- The specification requires being able to distinguish between signaling+-- @NaN@s (bit 0 of the bitmask) and quit @NaN@s (bit 1 of the bitmask), but+-- @crucible-llvm@ does not have the ability to do this. As a result, both+-- @NaN@ checks will always return true in this implementation, regardless of+-- whether they are signaling or quiet @NaN@s.+callIsFpclass ::+  forall fi p sym bak ext r args ret.+  IsSymBackend sym bak =>+  bak ->+  RegEntry sym (FloatType fi) ->+  RegEntry sym (BVType 32) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType 1))+callIsFpclass bak regOp@(regValue -> op) (regValue -> test) = do+  bvOne  <- liftIO $ bvLit sym w1 (BV.one w1)+  bvZero <- liftIO $ bvLit sym w1 (BV.zero w1)++  let negative bit = liftIO $ do+        isNeg <- iFloatIsNeg @_ @fi sym op+        liftIO $ bvIte sym isNeg bit bvZero++  let positive bit = liftIO $ do+        isPos <- iFloatIsPos @_ @fi sym op+        liftIO $ bvIte sym isPos bit bvZero++  let negAndPos doCheck = liftIO $ do+        check <- doCheck+        checkN <- negative check+        checkP <- positive check+        pure (checkN, checkP)++  let callIsInf x = do+        isInf <- iFloatIsInf @_ @fi sym x+        bvIte sym isInf bvOne bvZero++  let callIsNormal x = do+        isNorm <- iFloatIsNorm @_ @fi sym x+        bvIte sym isNorm bvOne bvZero++  let callIsSubnormal x = do+        isSubnorm <- iFloatIsSubnorm @_ @fi sym x+        bvIte sym isSubnorm bvOne bvZero++  let callIsZero x = do+        is0 <- iFloatIsZero @_ @fi sym x+        bvIte sym is0 bvOne bvZero++  isNan <- Libc.callIsnan bak w1 regOp+  (isInfN, isInfP) <- negAndPos $ callIsInf op+  (isNormN, isNormP) <- negAndPos $ callIsNormal op+  (isSubnormN, isSubnormP) <- negAndPos $ callIsSubnormal op+  (isZeroN, isZeroP) <- negAndPos $ callIsZero op++  foldM+    (\bits (bitNum, check) -> liftIO $ do+        isBitSet <- liftIO $ testBitBV sym bitNum test+        newBit <- liftIO $ bvIte sym isBitSet check bvZero+        liftIO $ bvOrBits sym newBit bits)+    bvZero+    [ (0, isNan)      -- Signaling NaN+    , (1, isNan)      -- Quiet NaN+    , (2, isInfN)     -- Negative infinity+    , (3, isNormN)    -- Negative normal+    , (4, isSubnormN) -- Negative subnormal+    , (5, isZeroN)    -- Negative zero+    , (6, isZeroP)    -- Positive zero+    , (7, isSubnormP) -- Positive subnormal+    , (8, isNormP)    -- Positive normal+    , (9, isInfP)     -- Positive infinity+    ]+  where+    sym = backendGetSym bak+    w1 = knownNat @1
+ src/Lang/Crucible/LLVM/Intrinsics/Libc.hs view
@@ -0,0 +1,1707 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libc+-- Description      : Override definitions for C standard library functions+-- Copyright        : (c) Galois, Inc 2015-2019+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc where++import           Control.Lens ((^.), _1, _2, _3)+import qualified Codec.Binary.UTF8.Generic as UTF8+import           Control.Monad (when)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.State (MonadState(..), StateT(..))+import           Control.Monad.Trans.Class (MonadTrans(..))+import qualified Data.ByteString as BS+import qualified Data.Vector as V+import           System.IO+import qualified GHC.Stack as GHC++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Context ( pattern (:>), pattern Empty )+import qualified Data.Parameterized.Context as Ctx++import           What4.Interface+import           What4.InterpretedFloatingPoint (IsInterpretedFloatExprBuilder(..))+import           What4.ProgramLoc (plSourceLoc)+import qualified What4.SpecialFunctions as W4++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.ExecutionTree+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.DataLayout+import qualified Lang.Crucible.LLVM.Errors.Poison as Poison+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.MalformedLLVMModule+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack)+import qualified Lang.Crucible.LLVM.MemModel.Type as G+import qualified Lang.Crucible.LLVM.MemModel.Generic as G+import           Lang.Crucible.LLVM.MemModel.Partial+import           Lang.Crucible.LLVM.Printf+import           Lang.Crucible.LLVM.QQ( llvmOvr )+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.LLVM.Intrinsics.Common+import           Lang.Crucible.LLVM.Intrinsics.Options++------------------------------------------------------------------------+-- ** Declarations+++llvmMemcpyOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+           (EmptyCtx ::> LLVMPointerType wptr+                     ::> LLVMPointerType wptr+                     ::> BVType wptr)+           (LLVMPointerType wptr)+llvmMemcpyOverride =+  [llvmOvr| i8* @memcpy( i8*, i8*, size_t ) |]+  (\memOps bak args ->+       do volatile <- liftIO $ RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat)+          Ctx.uncurryAssignment (callMemcpy bak memOps)+                                (args :> volatile)+          return $ regValue $ args^._1 -- return first argument+    )+++llvmMemcpyChkOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> LLVMPointerType wptr+                   ::> BVType wptr+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemcpyChkOverride =+  [llvmOvr| i8* @__memcpy_chk ( i8*, i8*, size_t, size_t ) |]+  (\memOps bak args ->+      do let args' = Empty :> (args^._1) :> (args^._2) :> (args^._3)+         volatile <- liftIO $ RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat)+         Ctx.uncurryAssignment (callMemcpy bak memOps)+                               (args' :> volatile)+         return $ regValue $ args^._1 -- return first argument+    )++llvmMemmoveOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> (LLVMPointerType wptr)+                   ::> (LLVMPointerType wptr)+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemmoveOverride =+  [llvmOvr| i8* @memmove( i8*, i8*, size_t ) |]+  (\memOps bak args ->+      do volatile <- liftIO (RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat))+         Ctx.uncurryAssignment (callMemmove bak memOps)+                               (args :> volatile)+         return $ regValue $ args^._1 -- return first argument+    )++llvmMemsetOverride :: forall p sym wptr.+     (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType 32+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemsetOverride =+  [llvmOvr| i8* @memset( i8*, i32, size_t ) |]+  (\memOps bak args ->+      do let sym = backendGetSym bak+         LeqProof <- return (leqTrans @9 @16 @wptr LeqProof LeqProof)+         let dest = args^._1+         val <- liftIO (RegEntry knownRepr <$> bvTrunc sym (knownNat @8) (regValue (args^._2)))+         let len = args^._3+         volatile <- liftIO+            (RegEntry knownRepr <$> bvLit sym knownNat (BV.zero knownNat))+         callMemset bak memOps dest val len volatile+         return (regValue dest)+    )++llvmMemsetChkOverride+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                 ::> BVType 32+                 ::> BVType wptr+                 ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemsetChkOverride =+  [llvmOvr| i8* @__memset_chk( i8*, i32, size_t, size_t ) |]+  (\memOps bak args ->+      do let sym = backendGetSym bak+         let dest = args^._1+         val <- liftIO+              (RegEntry knownRepr <$> bvTrunc sym knownNat (regValue (args^._2)))+         let len = args^._3+         volatile <- liftIO+            (RegEntry knownRepr <$> bvLit sym knownNat (BV.zero knownNat))+         callMemset bak memOps dest val len volatile+         return (regValue dest)+    )++------------------------------------------------------------------------+-- *** Allocation++llvmCallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> BVType wptr ::> BVType wptr)+         (LLVMPointerType wptr)+llvmCallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @calloc( size_t, size_t ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callCalloc bak memOps alignment) args)+++llvmReallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr)+         (LLVMPointerType wptr)+llvmReallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @realloc( i8*, size_t ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callRealloc bak memOps alignment) args)++llvmMallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @malloc( size_t ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callMalloc bak memOps alignment) args)++posixMemalignOverride ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?lc :: TypeContext, ?memOpts :: MemOptions ) =>+  LLVMOverride p sym+      (EmptyCtx ::> LLVMPointerType wptr+                ::> BVType wptr+                ::> BVType wptr)+      (BVType 32)+posixMemalignOverride =+  [llvmOvr| i32 @posix_memalign( i8**, size_t, size_t ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callPosixMemalign bak memOps) args)+++llvmFreeOverride+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr)+         UnitType+llvmFreeOverride =+  [llvmOvr| void @free( i8* ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callFree bak memOps) args)++------------------------------------------------------------------------+-- *** Strings and I/O++llvmPrintfOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> VectorType AnyType)+         (BVType 32)+llvmPrintfOverride =+  [llvmOvr| i32 @printf( i8*, ... ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callPrintf bak memOps) args)++llvmPrintfChkOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> BVType 32+                   ::> LLVMPointerType wptr+                   ::> VectorType AnyType)+         (BVType 32)+llvmPrintfChkOverride =+  [llvmOvr| i32 @__printf_chk( i32, i8*, ... ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (\_flg -> callPrintf bak memOps) args)+++llvmPutCharOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym (EmptyCtx ::> BVType 32) (BVType 32)+llvmPutCharOverride =+  [llvmOvr| i32 @putchar( i32 ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callPutChar bak memOps) args)+++llvmPutsOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) (BVType 32)+llvmPutsOverride =+  [llvmOvr| i32 @puts( i8* ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callPuts bak memOps) args)++llvmStrlenOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) (BVType wptr)+llvmStrlenOverride =+  [llvmOvr| size_t @strlen( i8* ) |]+  (\memOps bak args -> Ctx.uncurryAssignment (callStrlen bak memOps) args)++------------------------------------------------------------------------+-- ** Implementations++------------------------------------------------------------------------+-- *** Allocation++callRealloc+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> Alignment+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callRealloc bak mvar alignment (regValue -> ptr) (regValue -> sz) =+  do let sym = backendGetSym bak+     szZero  <- liftIO (notPred sym =<< bvIsNonzero sym sz)+     ptrNull <- liftIO (ptrIsNull sym PtrWidth ptr)+     loc <- liftIO (plSourceLoc <$> getCurrentProgramLoc sym)+     let displayString = "<realloc> " ++ show loc++     symbolicBranches emptyRegMap+       -- If the pointer is null, behave like malloc+       [ ( ptrNull+         , modifyGlobal mvar $ \mem -> liftIO $ doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment+         , Nothing+         )++       -- If the size is zero, behave like malloc (of zero bytes) then free+       , (szZero+         , modifyGlobal mvar $ \mem -> liftIO $+              do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment+                 mem2 <- doFree bak mem1 ptr+                 return (newp, mem2)+         , Nothing+         )++       -- Otherwise, allocate a new region, memcopy `sz` bytes and free the old pointer+       , (truePred sym+         , modifyGlobal mvar $ \mem -> liftIO $+              do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment+                 mem2 <- uncheckedMemcpy sym mem1 newp ptr sz+                 mem3 <- doFree bak mem2 ptr+                 return (newp, mem3)+         , Nothing)+       ]+++callPosixMemalign+  :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPosixMemalign bak mvar (regValue -> outPtr) (regValue -> align) (regValue -> sz) =+  let sym = backendGetSym bak in+  case asBV align of+    Nothing -> fail $ unwords ["posix_memalign: alignment value must be concrete:", show (printSymExpr align)]+    Just concrete_align ->+      case toAlignment (toBytes (BV.asUnsigned concrete_align)) of+        Nothing -> fail $ unwords ["posix_memalign: invalid alignment value:", show concrete_align]+        Just a ->+          let dl = llvmDataLayout ?lc in+          modifyGlobal mvar $ \mem -> liftIO $+             do loc <- plSourceLoc <$> getCurrentProgramLoc sym+                let displayString = "<posix_memaign> " ++ show loc+                (p, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz a+                mem'' <- storeRaw bak mem' outPtr (bitvectorType (dl^.ptrSize)) (dl^.ptrAlign) (ptrToPtrVal p)+                z <- bvLit sym knownNat (BV.zero knownNat)+                return (z, mem'')++callMalloc+  :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> Alignment+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callMalloc bak mvar alignment (regValue -> sz) =+  modifyGlobal mvar $ \mem -> liftIO $+    do loc <- plSourceLoc <$> getCurrentProgramLoc (backendGetSym bak)+       let displayString = "<malloc> " ++ show loc+       doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment++callCalloc+  :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> Alignment+  -> RegEntry sym (BVType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callCalloc bak mvar alignment+           (regValue -> sz)+           (regValue -> num) =+  modifyGlobal mvar $ \mem -> liftIO $+    doCalloc bak mem sz num alignment++callFree+  :: (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret ()+callFree bak mvar+           (regValue -> ptr) =+  modifyGlobal mvar $ \mem -> liftIO $+    do mem' <- doFree bak mem ptr+       return ((), mem')++------------------------------------------------------------------------+-- *** Memory manipulation++callMemcpy+  :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret ()+callMemcpy bak mvar+           (regValue -> dest)+           (regValue -> src)+           (RegEntry (BVRepr w) len)+           _volatile =+  modifyGlobal mvar $ \mem -> liftIO $+    do mem' <- doMemcpy bak w mem True dest src len+       return ((), mem')++-- NB the only difference between memcpy and memove+-- is that memmove does not assert that the memory+-- ranges are disjoint.  The underlying operation+-- works correctly in both cases.+callMemmove+  :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret ()+callMemmove bak mvar+           (regValue -> dest)+           (regValue -> src)+           (RegEntry (BVRepr w) len)+           _volatile =+  -- FIXME? add assertions about alignment+  modifyGlobal mvar $ \mem -> liftIO $+    do mem' <- doMemcpy bak w mem False dest src len+       return ((), mem')++callMemset+  :: (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType 8)+  -> RegEntry sym (BVType w)+  -> RegEntry sym (BVType 1)+  -> OverrideSim p sym ext r args ret ()+callMemset bak mvar+           (regValue -> dest)+           (regValue -> val)+           (RegEntry (BVRepr w) len)+           _volatile =+  modifyGlobal mvar $ \mem -> liftIO $+    do mem' <- doMemset bak w mem dest val len+       return ((), mem')++------------------------------------------------------------------------+-- *** Strings and I/O++callPutChar+  :: (IsSymBackend sym bak)+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (BVType 32)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPutChar _bak _mvar+ (regValue -> ch) = do+    h <- printHandle <$> getContext+    let chval = maybe '?' (toEnum . fromInteger) (BV.asUnsigned <$> asBV ch)+    liftIO $ hPutChar h chval+    return ch++callPuts+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPuts bak mvar+  (regValue -> strPtr) = do+    mem <- readGlobal mvar+    str <- liftIO $ loadString bak mem strPtr Nothing+    h <- printHandle <$> getContext+    liftIO $ hPutStrLn h (UTF8.toString str)+    -- return non-negative value on success+    liftIO $ bvLit (backendGetSym bak) knownNat (BV.one knownNat)++callStrlen+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr))+callStrlen bak mvar (regValue -> strPtr) = do+  mem <- readGlobal mvar+  liftIO $ strLen bak mem strPtr++callAssert+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => Bool -- ^ 'True' if this is @__assert_fail()@, 'False' otherwise.+  -> GlobalVar Mem+  -> bak+  -> Ctx.Assignment (RegEntry sym)+        (EmptyCtx ::> LLVMPointerType wptr+                  ::> LLVMPointerType wptr+                  ::> BVType 32+                  ::> LLVMPointerType wptr)+  -> forall r args reg.+     OverrideSim p sym ext r args reg (RegValue sym UnitType)+callAssert assert_fail mvar bak (Empty :> _pfn :> _pfile :> _pline :> ptxt ) =+  do let sym = backendGetSym bak+     when failUponExit $+       do mem <- readGlobal mvar+          txt <- liftIO $ loadString bak mem (regValue ptxt) Nothing+          let err = AssertFailureSimError "Call to assert()" (UTF8.toString txt)+          liftIO $ addFailedAssertion bak err+     liftIO $+       do loc <- liftIO $ getCurrentProgramLoc sym+          abortExecBecause $ EarlyExit loc+  where+    failUponExit :: Bool+    failUponExit+      | assert_fail+      = abnormalExitBehavior ?intrinsicsOpts `elem` [AlwaysFail, OnlyAssertFail]+      | otherwise+      = abnormalExitBehavior ?intrinsicsOpts == AlwaysFail++callExit :: ( IsSymBackend sym bak+            , ?intrinsicsOpts :: IntrinsicsOptions )+         => bak+         -> RegEntry sym (BVType 32)+         -> OverrideSim p sym ext r args ret (RegValue sym UnitType)+callExit bak ec = liftIO $+  do let sym = backendGetSym bak+     when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $+       do cond <- bvEq sym (regValue ec) =<< bvLit sym knownNat (BV.zero knownNat)+          -- If the argument is non-zero, throw an assertion failure. Otherwise,+          -- simply stop the current thread of execution.+          assert bak cond "Call to exit() with non-zero argument"+     loc <- getCurrentProgramLoc sym+     abortExecBecause $ EarlyExit loc++callPrintf+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (VectorType AnyType)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPrintf bak mvar+  (regValue -> strPtr)+  (regValue -> valist) = do+    mem <- readGlobal mvar+    formatStr <- liftIO $ loadString bak mem strPtr Nothing+    case parseDirectives formatStr of+      Left err -> overrideError $ AssertFailureSimError "Format string parsing failed" err+      Right ds -> do+        ((str, n), mem') <- liftIO $ runStateT (executeDirectives (printfOps bak valist) ds) mem+        writeGlobal mvar mem'+        h <- printHandle <$> getContext+        liftIO $ BS.hPutStr h str+        liftIO $ bvLit (backendGetSym bak) knownNat (BV.mkBV knownNat (toInteger n))++printfOps :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr+             , ?memOpts :: MemOptions )+          => bak+          -> V.Vector (AnyValue sym)+          -> PrintfOperations (StateT (MemImpl sym) IO)+printfOps bak valist =+  let sym = backendGetSym bak in+  PrintfOperations+  { printfUnsupported = \x -> lift $ addFailedAssertion bak+                                   $ Unsupported GHC.callStack x++  , printfGetInteger = \i sgn _len ->+     case valist V.!? (i-1) of+       Just (AnyValue (LLVMPointerRepr w) x) ->+         do bv <- liftIO (projectLLVM_bv bak x)+            if sgn then+              return $ BV.asSigned w <$> asBV bv+            else+              return $ BV.asUnsigned <$> asBV bv+       Just (AnyValue tpr _) ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Type mismatch in printf"+                (unwords ["Expected integer, but got:", show tpr])+       Nothing ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+               "Out-of-bounds argument access in printf"+               (unwords ["Index:", show i])++  , printfGetFloat = \i _len ->+     case valist V.!? (i-1) of+       Just (AnyValue (FloatRepr (_fi :: FloatInfoRepr fi)) x) ->+         do xr <- liftIO (iFloatToReal @_ @fi sym x)+            return (asRational xr)+       Just (AnyValue tpr _) ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Type mismatch in printf."+                (unwords ["Expected floating-point, but got:", show tpr])+       Nothing ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Out-of-bounds argument access in printf:"+                (unwords ["Index:", show i])++  , printfGetString  = \i numchars ->+     case valist V.!? (i-1) of+       Just (AnyValue PtrRepr ptr) ->+           do mem <- get+              liftIO $ loadString bak mem ptr numchars+       Just (AnyValue tpr _) ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Type mismatch in printf."+                (unwords ["Expected char*, but got:", show tpr])+       Nothing ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Out-of-bounds argument access in printf:"+                (unwords ["Index:", show i])++  , printfGetPointer = \i ->+     case valist V.!? (i-1) of+       Just (AnyValue PtrRepr ptr) ->+         return $ show (G.ppPtr ptr)+       Just (AnyValue tpr _) ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Type mismatch in printf."+                (unwords ["Expected void*, but got:", show tpr])+       Nothing ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Out-of-bounds argument access in printf:"+                (unwords ["Index:", show i])++  , printfSetInteger = \i len v ->+     case valist V.!? (i-1) of+       Just (AnyValue PtrRepr ptr) ->+         do mem <- get+            case len of+              Len_Byte  -> do+                 let w8 = knownNat :: NatRepr 8+                 let tp = G.bitvectorType 1+                 x <- liftIO (llvmPointer_bv sym =<< bvLit sym w8 (BV.mkBV w8 (toInteger v)))+                 mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w8) tp noAlignment x+                 put mem'+              Len_Short -> do+                 let w16 = knownNat :: NatRepr 16+                 let tp = G.bitvectorType 2+                 x <- liftIO (llvmPointer_bv sym =<< bvLit sym w16 (BV.mkBV w16 (toInteger v)))+                 mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w16) tp noAlignment x+                 put mem'+              Len_NoMod -> do+                 let w32  = knownNat :: NatRepr 32+                 let tp = G.bitvectorType 4+                 x <- liftIO (llvmPointer_bv sym =<< bvLit sym w32 (BV.mkBV w32 (toInteger v)))+                 mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w32) tp noAlignment x+                 put mem'+              Len_Long  -> do+                 let w64 = knownNat :: NatRepr 64+                 let tp = G.bitvectorType 8+                 x <- liftIO (llvmPointer_bv sym =<< bvLit sym w64 (BV.mkBV w64 (toInteger v)))+                 mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w64) tp noAlignment x+                 put mem'+              _ ->+                lift $ addFailedAssertion bak+                     $ Unsupported GHC.callStack+                     $ unwords ["Unsupported size modifier in %n conversion:", show len]++       Just (AnyValue tpr _) ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Type mismatch in printf."+                (unwords ["Expected void*, but got:", show tpr])++       Nothing ->+         lift $ addFailedAssertion bak+              $ AssertFailureSimError+                "Out-of-bounds argument access in printf:"+                (unwords ["Index:", show i])+  }++------------------------------------------------------------------------+-- *** Math++llvmCeilOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCeilOverride =+  [llvmOvr| double @ceil( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callCeil sym) args)++llvmCeilfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCeilfOverride =+  [llvmOvr| float @ceilf( float ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callCeil sym) args)+++llvmFloorOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmFloorOverride =+  [llvmOvr| double @floor( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callFloor sym) args)++llvmFloorfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmFloorfOverride =+  [llvmOvr| float @floorf( float ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callFloor sym) args)++llvmFmafOverride ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType SingleFloat+                  ::> FloatType SingleFloat+                  ::> FloatType SingleFloat)+        (FloatType SingleFloat)+llvmFmafOverride =+  [llvmOvr| float @fmaf( float, float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callFMA bak) args)++llvmFmaOverride ::+     forall sym p+   . IsSymInterface sym+  => LLVMOverride p sym+        (EmptyCtx ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat)+        (FloatType DoubleFloat)+llvmFmaOverride =+  [llvmOvr| double @fma( double, double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callFMA bak) args)+++-- math.h defines isinf() and isnan() as macros, so you might think it unusual+-- to provide function overrides for them. However, if you write, say,+-- (isnan)(x) instead of isnan(x), Clang will compile the former as a direct+-- function call rather than as a macro application. Some experimentation+-- reveals that the isnan function's argument is always a double, so we give its+-- argument the type double here to match this unstated convention. We follow+-- suit similarly with isinf.+--+-- Clang does not yet provide direct function call versions of isfinite() or+-- isnormal(), so we do not provide overrides for them.++llvmIsinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvmIsinfOverride =+  [llvmOvr| i32 @isinf( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args)++-- __isinf and __isinff are like the isinf macro, except their arguments are+-- known to be double or float, respectively. They are not mentioned in the+-- POSIX source standard, only the binary standard. See+-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinf.html and+-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinff.html.+llvm__isinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvm__isinfOverride =+  [llvmOvr| i32 @__isinf( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args)++llvm__isinffOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (BVType 32)+llvm__isinffOverride =+  [llvmOvr| i32 @__isinff( float ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args)++llvmIsnanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvmIsnanOverride =+  [llvmOvr| i32 @isnan( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args)++-- __isnan and __isnanf are like the isnan macro, except their arguments are+-- known to be double or float, respectively. They are not mentioned in the+-- POSIX source standard, only the binary standard. See+-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnan.html and+-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnanf.html.+llvm__isnanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvm__isnanOverride =+  [llvmOvr| i32 @__isnan( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args)++llvm__isnanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (BVType 32)+llvm__isnanfOverride =+  [llvmOvr| i32 @__isnanf( float ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args)+++llvmSqrtOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSqrtOverride =+  [llvmOvr| double @sqrt( double ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callSqrt sym) args)++llvmSqrtfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSqrtfOverride =+  [llvmOvr| float @sqrtf( float ) |]+  (\_memOps sym args -> Ctx.uncurryAssignment (callSqrt sym) args)++callSpecialFunction1 ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak, KnownRepr FloatInfoRepr fi) =>+  bak ->+  W4.SpecialFunction (EmptyCtx ::> W4.R) ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callSpecialFunction1 bak fn (regValue -> x) = liftIO $+  iFloatSpecialFunction1 (backendGetSym bak) (knownRepr :: FloatInfoRepr fi) fn x++callSpecialFunction2 ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak, KnownRepr FloatInfoRepr fi) =>+  bak ->+  W4.SpecialFunction (EmptyCtx ::> W4.R ::> W4.R) ->+  RegEntry sym (FloatType fi) ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callSpecialFunction2 bak fn (regValue -> x) (regValue -> y) = liftIO $+  iFloatSpecialFunction2 (backendGetSym bak) (knownRepr :: FloatInfoRepr fi) fn x y++callCeil ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak) =>+  bak ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callCeil bak (regValue -> x) = liftIO $ iFloatRound @_ @fi (backendGetSym bak) RTP x++callFloor ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak) =>+  bak ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callFloor bak (regValue -> x) = liftIO $ iFloatRound @_ @fi (backendGetSym bak) RTN x++-- | An implementation of @libc@'s @fma@ function.+callFMA ::+     forall fi p sym bak ext r args ret+   . IsSymBackend sym bak+  => bak+  -> RegEntry sym (FloatType fi)+  -> RegEntry sym (FloatType fi)+  -> RegEntry sym (FloatType fi)+  -> OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callFMA bak (regValue -> x) (regValue -> y) (regValue -> z) = liftIO $+  iFloatFMA @_ @fi (backendGetSym bak) defaultRM x y z++-- | An implementation of @libc@'s @isinf@ macro. This returns @1@ when the+-- argument is positive infinity, @-1@ when the argument is negative infinity,+-- and zero otherwise.+callIsinf ::+  forall fi w p sym bak ext r args ret.+  (IsSymBackend sym bak, 1 <= w) =>+  bak ->+  NatRepr w ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callIsinf bak w (regValue -> x) = liftIO $ do+  let sym = backendGetSym bak+  isInf <- iFloatIsInf @_ @fi sym x+  isNeg <- iFloatIsNeg @_ @fi sym x+  isPos <- iFloatIsPos @_ @fi sym x+  isInfN <- andPred sym isInf isNeg+  isInfP <- andPred sym isInf isPos+  bvOne    <- bvLit sym w (BV.one w)+  bvNegOne <- bvNeg sym bvOne+  bvZero   <- bvLit sym w (BV.zero w)+  res0 <- bvIte sym isInfP bvOne bvZero+  bvIte sym isInfN bvNegOne res0++callIsnan ::+  forall fi w p sym bak ext r args ret.+  (IsSymBackend sym bak, 1 <= w) =>+  bak ->+  NatRepr w ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callIsnan bak w (regValue -> x) = liftIO $ do+  let sym = backendGetSym bak+  isnan  <- iFloatIsNaN @_ @fi sym x+  bvOne  <- bvLit sym w (BV.one w)+  bvZero <- bvLit sym w (BV.zero w)+  -- isnan() is allowed to return any nonzero value if the argument is NaN, and+  -- out of all the possible nonzero values, `1` is certainly one of them.+  bvIte sym isnan bvOne bvZero++callSqrt ::+  forall fi p sym bak ext r args ret.+  (IsSymBackend sym bak) =>+  bak ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callSqrt bak (regValue -> x) = liftIO $ iFloatSqrt @_ @fi (backendGetSym bak) defaultRM x++------------------------------------------------------------------------+-- **** Circular trigonometry functions++-- sin(f)++llvmSinOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinOverride =+  [llvmOvr| double @sin( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sin) args)++llvmSinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinfOverride =+  [llvmOvr| float @sinf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sin) args)++-- cos(f)++llvmCosOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCosOverride =+  [llvmOvr| double @cos( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cos) args)++llvmCosfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCosfOverride =+  [llvmOvr| float @cosf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cos) args)++-- tan(f)++llvmTanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanOverride =+  [llvmOvr| double @tan( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tan) args)++llvmTanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanfOverride =+  [llvmOvr| float @tanf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tan) args)++-- asin(f)++llvmAsinOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAsinOverride =+  [llvmOvr| double @asin( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsin) args)++llvmAsinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAsinfOverride =+  [llvmOvr| float @asinf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsin) args)++-- acos(f)++llvmAcosOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAcosOverride =+  [llvmOvr| double @acos( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccos) args)++llvmAcosfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAcosfOverride =+  [llvmOvr| float @acosf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccos) args)++-- atan(f)++llvmAtanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtanOverride =+  [llvmOvr| double @atan( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctan) args)++llvmAtanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtanfOverride =+  [llvmOvr| float @atanf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctan) args)++------------------------------------------------------------------------+-- **** Hyperbolic trigonometry functions++-- sinh(f)++llvmSinhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinhOverride =+  [llvmOvr| double @sinh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sinh) args)++llvmSinhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinhfOverride =+  [llvmOvr| float @sinhf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sinh) args)++-- cosh(f)++llvmCoshOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCoshOverride =+  [llvmOvr| double @cosh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cosh) args)++llvmCoshfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCoshfOverride =+  [llvmOvr| float @coshf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cosh) args)++-- tanh(f)++llvmTanhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanhOverride =+  [llvmOvr| double @tanh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tanh) args)++llvmTanhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanhfOverride =+  [llvmOvr| float @tanhf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tanh) args)++-- asinh(f)++llvmAsinhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAsinhOverride =+  [llvmOvr| double @asinh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsinh) args)++llvmAsinhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAsinhfOverride =+  [llvmOvr| float @asinhf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsinh) args)++-- acosh(f)++llvmAcoshOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAcoshOverride =+  [llvmOvr| double @acosh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccosh) args)++llvmAcoshfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAcoshfOverride =+  [llvmOvr| float @acoshf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccosh) args)++-- atanh(f)++llvmAtanhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtanhOverride =+  [llvmOvr| double @atanh( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctanh) args)++llvmAtanhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtanhfOverride =+  [llvmOvr| float @atanhf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctanh) args)++------------------------------------------------------------------------+-- **** Rectangular to polar coordinate conversion++-- hypot(f)++llvmHypotOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmHypotOverride =+  [llvmOvr| double @hypot( double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Hypot) args)++llvmHypotfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmHypotfOverride =+  [llvmOvr| float @hypotf( float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Hypot) args)++-- atan2(f)++llvmAtan2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtan2Override =+  [llvmOvr| double @atan2( double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Arctan2) args)++llvmAtan2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtan2fOverride =+  [llvmOvr| float @atan2f( float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Arctan2) args)++------------------------------------------------------------------------+-- **** Exponential and logarithm functions++-- pow(f)++llvmPowfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmPowfOverride =+  [llvmOvr| float @powf( float, float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Pow) args)++llvmPowOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmPowOverride =+  [llvmOvr| double @pow( double, double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Pow) args)++-- exp(f)++llvmExpOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExpOverride =+  [llvmOvr| double @exp( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp) args)++llvmExpfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExpfOverride =+  [llvmOvr| float @expf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp) args)++-- log(f)++llvmLogOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLogOverride =+  [llvmOvr| double @log( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log) args)++llvmLogfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLogfOverride =+  [llvmOvr| float @logf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log) args)++-- expm1(f)++llvmExpm1Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExpm1Override =+  [llvmOvr| double @expm1( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Expm1) args)++llvmExpm1fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExpm1fOverride =+  [llvmOvr| float @expm1f( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Expm1) args)++-- log1p(f)++llvmLog1pOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog1pOverride =+  [llvmOvr| double @log1p( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log1p) args)++llvmLog1pfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog1pfOverride =+  [llvmOvr| float @log1pf( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log1p) args)++------------------------------------------------------------------------+-- **** Base 2 exponential and logarithm++-- exp2(f)++llvmExp2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExp2Override =+  [llvmOvr| double @exp2( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp2) args)++llvmExp2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExp2fOverride =+  [llvmOvr| float @exp2f( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp2) args)++-- log2(f)++llvmLog2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog2Override =+  [llvmOvr| double @log2( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log2) args)++llvmLog2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog2fOverride =+  [llvmOvr| float @log2f( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log2) args)++------------------------------------------------------------------------+-- **** Base 10 exponential and logarithm++-- exp10(f)++llvmExp10Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExp10Override =+  [llvmOvr| double @exp10( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp10) args)++llvmExp10fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExp10fOverride =+  [llvmOvr| float @exp10f( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp10) args)++-- log10(f)++llvmLog10Override ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog10Override =+  [llvmOvr| double @log10( double ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log10) args)++llvmLog10fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog10fOverride =+  [llvmOvr| float @log10f( float ) |]+  (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log10) args)++------------------------------------------------------------------------+-- *** Other++-- from OSX libc+llvmAssertRtnOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => LLVMOverride p sym+        (EmptyCtx ::> LLVMPointerType wptr+                  ::> LLVMPointerType wptr+                  ::> BVType 32+                  ::> LLVMPointerType wptr)+        UnitType+llvmAssertRtnOverride =+  [llvmOvr| void @__assert_rtn( i8*, i8*, i32, i8* ) |]+  (callAssert False)++-- From glibc+llvmAssertFailOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => LLVMOverride p sym+        (EmptyCtx ::> LLVMPointerType wptr+                  ::> LLVMPointerType wptr+                  ::> BVType 32+                  ::> LLVMPointerType wptr)+        UnitType+llvmAssertFailOverride =+  [llvmOvr| void @__assert_fail( i8*, i8*, i32, i8* ) |]+  (callAssert True)+++llvmAbortOverride+  :: ( IsSymInterface sym+     , ?intrinsicsOpts :: IntrinsicsOptions )+  => LLVMOverride p sym EmptyCtx UnitType+llvmAbortOverride =+  [llvmOvr| void @abort() |]+  (\_ bak _args -> liftIO $+     do let sym = backendGetSym bak+        when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $+            let err = AssertFailureSimError "Call to abort" "" in+            assert bak (falsePred sym) err+        loc <- getCurrentProgramLoc sym+        abortExecBecause $ EarlyExit loc+  )++llvmExitOverride+  :: forall sym p+   . ( IsSymInterface sym+     , ?intrinsicsOpts :: IntrinsicsOptions )+  => LLVMOverride p sym+         (EmptyCtx ::> BVType 32)+         UnitType+llvmExitOverride =+  [llvmOvr| void @exit( i32 ) |]+  (\_ bak args -> Ctx.uncurryAssignment (callExit bak) args)++llvmGetenvOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym+        (EmptyCtx ::> LLVMPointerType wptr)+        (LLVMPointerType wptr)+llvmGetenvOverride =+  [llvmOvr| i8* @getenv( i8* ) |]+  (\_ bak _args -> liftIO $ mkNullPointer (backendGetSym bak) PtrWidth)++llvmHtonlOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmHtonlOverride =+  [llvmOvr| i32 @htonl( i32 ) |]+  (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @4)) args)++llvmHtonsOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 16)+      (BVType 16)+llvmHtonsOverride =+  [llvmOvr| i16 @htons( i16 ) |]+  (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @2)) args)++llvmNtohlOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmNtohlOverride =+  [llvmOvr| i32 @ntohl( i32 ) |]+  (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @4)) args)++llvmNtohsOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 16)+      (BVType 16)+llvmNtohsOverride =+  [llvmOvr| i16 @ntohs( i16 ) |]+  (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @2)) args)++llvmAbsOverride ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmAbsOverride =+  [llvmOvr| i32 @abs( i32 ) |]+  (\mvar bak args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @32)) args)++-- @labs@ uses `long` as its argument and result type, so we need two overrides+-- for @labs@. See Note [Overrides involving (unsigned) long] in+-- Lang.Crucible.LLVM.Intrinsics.+llvmLAbsOverride_32 ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmLAbsOverride_32 =+  [llvmOvr| i32 @labs( i32 ) |]+  (\mvar bak args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @32)) args)++llvmLAbsOverride_64 ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 64)+      (BVType 64)+llvmLAbsOverride_64 =+  [llvmOvr| i64 @labs( i64 ) |]+  (\mvar bak args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @64)) args)++llvmLLAbsOverride ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym+      (EmptyCtx ::> BVType 64)+      (BVType 64)+llvmLLAbsOverride =+  [llvmOvr| i64 @llabs( i64 ) |]+  (\mvar bak args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @64)) args)++callBSwap ::+  (1 <= width, IsSymBackend sym bak) =>+  bak ->+  NatRepr width ->+  RegEntry sym (BVType (width * 8)) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))+callBSwap bak widthRepr (regValue -> vec) =+  liftIO $ bvSwap (backendGetSym bak) widthRepr vec++-- | This determines under what circumstances @callAbs@ should check if its+-- argument is equal to the smallest signed integer of a particular size+-- (e.g., @INT_MIN@), and if it is equal to that value, what kind of error+-- should be reported.+data CheckAbsIntMin+  = LibcAbsIntMinUB+    -- ^ For the @abs@, @labs@, and @llabs@ functions, always check if the+    --   argument is equal to @INT_MIN@. If so, report it as undefined+    --   behavior per the C standard.+  | LLVMAbsIntMinPoison Bool+    -- ^ For the @llvm.abs.*@ family of LLVM intrinsics, check if the argument+    --   is equal to @INT_MIN@ only when the 'Bool' argument is 'True'. If it+    --   is 'True' and the argument is equal to @INT_MIN@, return poison.++-- | The workhorse for the @abs@, @labs@, and @llabs@ functions, as well as the+-- @llvm.abs.*@ family of overloaded intrinsics.+callAbs ::+  forall w p sym bak ext r args ret.+  (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) =>+  bak ->+  CallStack ->+  CheckAbsIntMin ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callAbs bak callStack checkIntMin widthRepr (regValue -> src) = liftIO $ do+  let sym = backendGetSym bak+  bvIntMin    <- bvLit sym widthRepr (BV.minSigned widthRepr)+  isNotIntMin <- notPred sym =<< bvEq sym src bvIntMin++  when shouldCheckIntMin $ do+    isNotIntMinUB <- annotateUB sym callStack ub isNotIntMin+    let err = AssertFailureSimError "Undefined behavior encountered" $+              show $ UB.explain ub+    assert bak isNotIntMinUB err++  isSrcNegative <- bvIsNeg sym src+  srcNegated    <- bvNeg sym src+  bvIte sym isSrcNegative srcNegated src+  where+    shouldCheckIntMin :: Bool+    shouldCheckIntMin =+      case checkIntMin of+        LibcAbsIntMinUB                 -> True+        LLVMAbsIntMinPoison shouldCheck -> shouldCheck++    ub :: UB.UndefinedBehavior (RegValue' sym)+    ub = case checkIntMin of+           LibcAbsIntMinUB ->+             UB.AbsIntMin $ RV src+           LLVMAbsIntMinPoison{} ->+             UB.PoisonValueCreated $ Poison.LLVMAbsIntMin $ RV src++callLibcAbs ::+  (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) =>+  bak ->+  CallStack ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callLibcAbs bak callStack = callAbs bak callStack LibcAbsIntMinUB++callLLVMAbs ::+  (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) =>+  bak ->+  CallStack ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  RegEntry sym (BVType 1) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callLLVMAbs bak callStack widthRepr src (regValue -> isIntMinPoison) = do+  shouldCheckIntMin <- liftIO $+    -- Per https://releases.llvm.org/12.0.0/docs/LangRef.html#id451, the second+    -- argument must be a constant.+    case asBV isIntMinPoison of+      Just bv -> pure (bv /= BV.zero (knownNat @1))+      Nothing -> malformedLLVMModule+                   "Call to llvm.abs.* with non-constant second argument"+                   [printSymExpr isIntMinPoison]+  callAbs bak callStack (LLVMAbsIntMinPoison shouldCheckIntMin) widthRepr src++-- | If the data layout is little-endian, run 'callBSwap' on the input.+-- Otherwise, return the input unchanged. This is the workhorse for the+-- @hton{s,l}@ and @ntoh{s,l}@ overrides.+callBSwapIfLittleEndian ::+  (1 <= width, IsSymBackend sym bak, ?lc :: TypeContext) =>+  bak ->+  NatRepr width ->+  RegEntry sym (BVType (width * 8)) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))+callBSwapIfLittleEndian bak widthRepr vec =+  case (llvmDataLayout ?lc)^.intLayout of+    BigEndian    -> pure (regValue vec)+    LittleEndian -> callBSwap bak widthRepr vec++----------------------------------------------------------------------------+-- atexit stuff++cxa_atexitOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym+        (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> LLVMPointerType wptr)+        (BVType 32)+cxa_atexitOverride =+  [llvmOvr| i32 @__cxa_atexit( void (i8*)*, i8*, i8* ) |]+  (\_ bak _args -> liftIO $ bvLit (backendGetSym bak) knownNat (BV.zero knownNat))++----------------------------------------------------------------------------++-- | IEEE 754 declares 'RNE' to be the default rounding mode, and most @libc@+-- implementations agree with this in practice. The only places where we do not+-- use this as the default are operations that specifically require the behavior+-- of a particular rounding mode, such as @ceil@ or @floor@.+defaultRM :: RoundingMode+defaultRM = RNE
+ src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs view
@@ -0,0 +1,301 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libcxx+-- Description      : Override definitions for C++ standard library functions+-- Copyright        : (c) Galois, Inc 2015-2019+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.Intrinsics.Libcxx+  ( register_cpp_override+    -- ** iostream+  , putToOverride12+  , putToOverride9+  , endlOverride+  , sentryOverride+  , sentryBoolOverride+  ) where++import qualified ABI.Itanium as ABI+import           Control.Applicative (empty)+import           Control.Lens ((^.))+import           Control.Monad.Reader+import           Data.List (isInfixOf)+import           Data.Type.Equality ((:~:)(Refl), testEquality)+import qualified Text.LLVM.AST as L++import qualified Data.BitVector.Sized as BV+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr (knownNat)++import           What4.Interface (bvLit, natLit)++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common (GlobalVar)+import           Lang.Crucible.Simulator.RegMap (RegValue, regValue)+import           Lang.Crucible.Panic (panic)+import           Lang.Crucible.Types (TypeRepr(UnitRepr), CtxRepr)++import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.Intrinsics.Common+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Types++------------------------------------------------------------------------+-- ** General++-- | C++ overrides generally have a bit more work to do: their types are more+-- complex, their names are mangled in the LLVM module, it's a big mess.+register_cpp_override ::+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  SomeCPPOverride p sym arch ->+  OverrideTemplate p sym arch rtp l a+register_cpp_override someCPPOverride =+  OverrideTemplate (SubstringsMatch ("_Z" : cppOverrideSubstrings someCPPOverride)) $+  do (requestedDecl, decName, llvmctx) <- ask+     case decName of+       Nothing -> empty+       Just nm ->+         case cppOverrideAction someCPPOverride requestedDecl nm llvmctx of+           Nothing -> empty+           Just (SomeLLVMOverride override) -> register_llvm_override override+++-- type CPPOverride p sym arch args ret =+--   L.Declare -> LLVMContext arch -> Maybe (LLVMOverride p sym arch args ret)++-- | We can only tell whether we should install a C++ override after demangling+--  the function name, which is expensive. As a first approximation, we ask whether+--  the function's name contains a few substrings, in order.+data SomeCPPOverride p sym arch =+  SomeCPPOverride+  { cppOverrideSubstrings :: [String]+  , cppOverrideAction :: L.Declare -> ABI.DecodedName -> LLVMContext arch -> Maybe (SomeLLVMOverride p sym)+  }++------------------------------------------------------------------------+-- ** No-ops++------------------------------------------------------------------------+-- *** Utilities++matchSymbolName :: (L.Symbol -> ABI.DecodedName -> Bool)+                -> L.Declare+                -> ABI.DecodedName+                -> Maybe a+                -> Maybe a+matchSymbolName match decl decodedName =+  if not (match (L.decName decl) decodedName)+  then const Nothing+  else id++panic_ :: (Show a, Show b)+       => String+       -> L.Declare+       -> a+       -> b+       -> c+panic_ from decl args ret =+  panic from [ "Ill-typed override"+             , "Name: " ++ nm+             , "Args: " ++ show args+             , "Ret:  " ++ show ret+             ]+  where L.Symbol nm = L.decName decl++-- | If the requested declaration's symbol matches the filter, look up its+-- function handle in the symbol table and use that to construct an override+mkOverride :: (IsSymInterface sym, HasPtrWidth (ArchWidth arch))+           => [String] -- ^ Substrings for name filtering+           -> (forall args ret. L.Declare -> CtxRepr args -> TypeRepr ret -> Maybe (SomeLLVMOverride p sym))+           -> (L.Symbol -> ABI.DecodedName -> Bool)+           -> SomeCPPOverride p sym arch+mkOverride substrings ov filt =+  SomeCPPOverride substrings $ \requestedDecl decodedName llvmctx ->+    let ?lc = llvmctx^.llvmTypeCtx in+    matchSymbolName filt requestedDecl decodedName $+      llvmDeclToFunHandleRepr' requestedDecl $ \argTys retTy ->+        ov requestedDecl argTys retTy++------------------------------------------------------------------------+-- *** No-op override builders++-- | Make an override for a function which doesn't return anything.+voidOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+             => [String]+             -> (L.Symbol -> ABI.DecodedName -> Bool)+             -> SomeCPPOverride p sym arch+voidOverride substrings =+  mkOverride substrings $ \decl argTys retTy -> Just $+      case retTy of+        UnitRepr -> SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym _args -> pure ()+        _ -> panic_ "voidOverride" decl argTys retTy++-- | Make an override for a function of (LLVM) type @a -> a@, for any @a@.+--+-- The override simply returns its input.+identityOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+                 => [String]+                 -> (L.Symbol -> ABI.DecodedName -> Bool)+                 -> SomeCPPOverride p sym arch+identityOverride substrings =+  mkOverride substrings $ \decl argTys retTy -> Just $+    case argTys of+      (Ctx.Empty Ctx.:> argTy)+        | Just Refl <- testEquality argTy retTy ->+            SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args ->+              -- Just return the input+              pure (Ctx.uncurryAssignment regValue args)++      _ -> panic_ "identityOverride" decl argTys retTy++-- | Make an override for a function of (LLVM) type @a -> b -> a@, for any @a@.+--+-- The override simply returns its first input.+constOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+              => [String]+              -> (L.Symbol -> ABI.DecodedName -> Bool)+              -> SomeCPPOverride p sym arch+constOverride substrings =+  mkOverride substrings $ \decl argTys retTy -> Just $+    case argTys of+      (Ctx.Empty Ctx.:> fstTy Ctx.:> _)+        | Just Refl <- testEquality fstTy retTy ->+        SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args ->+          pure (Ctx.uncurryAssignment (const . regValue) args)++      _ -> panic_ "constOverride" decl argTys retTy++-- | Make an override that always returns the same value.+fixedOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+              => TypeRepr ty+              -> (GlobalVar Mem -> sym -> IO (RegValue sym ty))+              -> [String]+              -> (L.Symbol -> ABI.DecodedName -> Bool)+              -> SomeCPPOverride p sym arch+fixedOverride ty regval substrings =+  mkOverride substrings $ \decl argTys retTy -> Just $+    case testEquality retTy ty of+      Just Refl ->+        SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \mem bak _args ->+          liftIO (regval mem (backendGetSym bak))++      _ -> panic_ "fixedOverride" decl argTys retTy++-- | Return @true@.+trueOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+             => [String]+             -> (L.Symbol -> ABI.DecodedName -> Bool)+             -> SomeCPPOverride p sym arch+trueOverride =+  fixedOverride (LLVMPointerRepr knownNat) $ \_mem sym ->+    LLVMPointer <$> natLit sym 0 <*> bvLit sym (knownNat @1) (BV.one knownNat)++------------------------------------------------------------------------+-- ** Declarations++------------------------------------------------------------------------+-- *** iostream++------------------------------------------------------------------------+-- **** basic_ostream++-- | Override for the \"put to\" operator, @<<@+--+-- This is the override for the 12th function signature listed here:+-- https://en.cppreference.com/w/cpp/io/basic_ostream/operator_ltlt+putToOverride12 :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+                => SomeCPPOverride p sym arch+putToOverride12 =+  constOverride ["St","ls","basic_ostream"] $ \_ decodedName ->+    case decodedName of+      ABI.Function+         (ABI.NestedName+          []+          [ ABI.SubstitutionPrefix ABI.SubStdNamespace+          , _+          , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream")+          , ABI.TemplateArgsPrefix _+          ]+          (ABI.OperatorName ABI.OpShl))+          [ABI.PointerToType (ABI.FunctionType _)] -> True+      _ -> False++-- | Override for the \"put to\" operator, @<<@+--+-- This is the override for the 9th function signature listed here (I think):+-- https://en.cppreference.com/w/cpp/io/basic_ostream/operator_ltlt+putToOverride9 :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+               => SomeCPPOverride p sym arch+putToOverride9 =+  constOverride ["NSt3__1lsINS_11char_traitsIcEEEERNS_13basic_ostreamIcT_EES6_PKc"] $ \(L.Symbol nm) _ ->+    nm == "_ZNSt3__1lsINS_11char_traitsIcEEEERNS_13basic_ostreamIcT_EES6_PKc"++-- | TODO: When @itanium-abi@ get support for parsing templates, make this a+-- more structured match+endlOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+             => SomeCPPOverride p sym arch+endlOverride =+  identityOverride ["endl","char_traits","basic_ostream"] $ \(L.Symbol nm) _decodedName ->+    and [ "endl"          `isInfixOf` nm+        , "char_traits"   `isInfixOf` nm+        , "basic_ostream" `isInfixOf` nm+        ]++sentryOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+               => SomeCPPOverride p sym arch+sentryOverride =+  voidOverride ["basic_ostream", "sentry"] $ \_nm decodedName ->+    case decodedName of+      ABI.Function+         (ABI.NestedName+          []+          [ ABI.SubstitutionPrefix ABI.SubStdNamespace+          , _+          , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream")+          , _+          , ABI.UnqualifiedPrefix (ABI.SourceName "sentry")+          ]+          _)+         _ -> True+      _ -> False++-- | An override of the @bool@ operator (cast) on the @sentry@ class,+--+-- @sentry::operator bool()@+sentryBoolOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)+                   => SomeCPPOverride p sym arch+sentryBoolOverride =+  trueOverride ["basic_ostream", "sentry"] $ \_nm decodedName ->+    case decodedName of+      ABI.Function+         (ABI.NestedName+          [ABI.Const]+          [ ABI.SubstitutionPrefix ABI.SubStdNamespace+          , _+          , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream")+          , _+          , ABI.UnqualifiedPrefix (ABI.SourceName "sentry")+          ]+          (ABI.OperatorName (ABI.OpCast ABI.BoolType)))+          [ABI.VoidType] -> True+      _ -> False
+ src/Lang/Crucible/LLVM/Intrinsics/Options.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Options+-- Description      : Definition of options that affect LLVM overrides+-- Copyright        : (c) Galois, Inc 2021+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------+module Lang.Crucible.LLVM.Intrinsics.Options+  ( IntrinsicsOptions(..)+  , AbnormalExitBehavior(..)+  , defaultIntrinsicsOptions+  ) where++-- | Should Crucible fail when simulating a function which triggers an abnormal+-- exit, such as @abort()@?+data AbnormalExitBehavior+  = AlwaysFail+    -- ^ Functions which trigger an abnormal exit will always cause Crucible+    --   to fail.+  | OnlyAssertFail+    -- ^ The @__assert_fail()@ function will cause Crucible to fail, while+    --   other functions which triggern an abnormal exit will not cause+    --   failures. This option is primarily useful for SV-COMP.+  | NeverFail+    -- ^ Functions which trigger an abnormal exit will never cause Crucible+    --   to fail. This option is primarily useful for SV-COMP.+  deriving Eq++-- | This datatype encodes a variety of tweakable settings that to LLVM+--   overrides.+newtype IntrinsicsOptions+  = IntrinsicsOptions+    { abnormalExitBehavior :: AbnormalExitBehavior+      -- ^ Should Crucible fail when simulating a function which triggers an+      --   abnormal exit, such as @abort()@?+    }++-- | The default translation options:+--+-- * Functions which trigger an abnormal exit will always cause Crucible+--   to fail.+defaultIntrinsicsOptions :: IntrinsicsOptions+defaultIntrinsicsOptions =+  IntrinsicsOptions+  { abnormalExitBehavior = AlwaysFail+  }
+ src/Lang/Crucible/LLVM/MalformedLLVMModule.hs view
@@ -0,0 +1,31 @@+module Lang.Crucible.LLVM.MalformedLLVMModule where++import qualified Control.Exception as X+import           Data.Void++import           Prettyprinter++------------------------------------------------------------------------+-- MalformedLLVMModule++-- | This datatype represents an exception that occurs when an LLVM module+--   is broken in some way; for example, if the types of expressions do+--   not match up in some way.  The first argument is a short description+--   of the error, and the remaining arguments are any additional details+--   describing the error.+data MalformedLLVMModule+  = MalformedLLVMModule (Doc Void) [Doc Void]++instance X.Exception MalformedLLVMModule++instance Show MalformedLLVMModule where+  show = show . renderMalformedLLVMModule++-- Throw a @MalformedLLVMModule@ exception+malformedLLVMModule :: Doc Void -> [Doc Void] -> a+malformedLLVMModule short details = X.throw (MalformedLLVMModule short details)++-- Render a @MalformedLLVMModule@ exception as a pretty printer document+renderMalformedLLVMModule :: MalformedLLVMModule -> Doc Void+renderMalformedLLVMModule (MalformedLLVMModule short details) =+  vcat [short, indent 2 (vcat details)]
+ src/Lang/Crucible/LLVM/MemModel.hs view
@@ -0,0 +1,1896 @@+--------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel+-- Description      : Core definitions of the symbolic C memory model+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Lang.Crucible.LLVM.MemModel+  ( -- * Memories+    Mem+  , memRepr+  , mkMemVar+  , MemImpl(..)+  , SomePointer(..)+  , GlobalMap+  , emptyMem+  , memEndian+  , memAllocCount+  , memWriteCount+  , G.ppMem+  , doDumpMem+  , BlockSource(..)+  , nextBlock+  , MemOptions(..)+  , IndeterminateLoadBehavior(..)+  , defaultMemOptions+  , laxPointerMemOptions++  -- * Pointers+  , LLVMPointerType+  , pattern LLVMPointerRepr+  , pattern PtrRepr+  , pattern SizeT+  , LLVMPtr+  , pattern LLVMPointer+  , llvmPointerView+  , ptrWidth+  , G.ppPtr+  , G.ppTermExpr+  , llvmPointer_bv+  , Partial.projectLLVM_bv++    -- * Memory operations+  , doMalloc+  , doMallocUnbounded+  , G.AllocType(..)+  , G.Mutability(..)+  , doMallocHandle+  , ME.FuncLookupError(..)+  , ME.ppFuncLookupError+  , doLookupHandle+  , doInstallHandle+  , doMemcpy+  , doMemset+  , doInvalidate+  , doCalloc+  , doFree+  , doAlloca+  , doLoad+  , doStore+  , doArrayStore+  , doArrayStoreUnbounded+  , doArrayConstStore+  , doArrayConstStoreUnbounded+  , loadString+  , loadMaybeString+  , strLen+  , uncheckedMemcpy+  , bindLLVMFunPtr++    -- * \"Raw\" operations with LLVMVal+  , LLVMVal(..)+  , ppLLVMValWithGlobals+  , FloatSize(..)+  , unpackMemValue+  , packMemValue+  , loadRaw+  , storeRaw+  , condStoreRaw+  , storeConstRaw+  , mallocRaw+  , mallocConstRaw+  , constToLLVMVal+  , constToLLVMValP+  , ptrMessage+  , Partial.PartLLVMVal(..)+  , Partial.assertSafe+  , explodeStringValue++    -- Re-exports from MemModel.Value+  , isZero+  , testEqual+  , llvmValStorableType++    -- * Storage types+  , StorageType+  , storageTypeF+  , StorageTypeF(..)+  , Field+  , storageTypeSize+  , fieldVal+  , fieldPad+  , fieldOffset+  , bitvectorType+  , arrayType+  , mkStructType+  , floatType+  , doubleType+  , x86_fp80Type+  , toStorableType++    -- * Pointer operations+  , ptrToPtrVal+  , mkNullPointer+  , ptrIsNull+  , ptrEq+  , ptrAdd+  , ptrSub+  , ptrDiff+  , doPtrAddOffset+  , doPtrSubtract+  , isValidPointer+  , isAllocatedAlignedPointer+  , muxLLVMPtr+  , G.isAligned++    -- * Disjointness+  , assertDisjointRegions+  , buildDisjointRegionsAssertion+  , buildDisjointRegionsAssertionWithSub++    -- * Globals+  , GlobalSymbol(..)+  , doResolveGlobal+  , registerGlobal+  , allocGlobals+  , allocGlobal+  , isGlobalPointer++    -- * Misc+  , llvmStatementExec+  , G.pushStackFrameMem+  , G.popStackFrameMem+  , G.asMemAllocationArrayStore+  , SomeFnHandle(..)+  , G.SomeAlloc(..)+  , G.possibleAllocs+  , G.ppSomeAlloc+  , doConditionalWriteOperation+  , mergeWriteOperations+  , Partial.HasLLVMAnn+  , Partial.LLVMAnnMap+  , Partial.CexExplanation(..)+  , Partial.explainCex++    -- * PtrWidth (re-exports)+  , HasPtrWidth+  , pattern PtrWidth+  , withPtrWidth++    -- * Concretization+  , ML.concPtr+  , ML.concLLVMVal+  , ML.concMem+  , concMemImpl+  ) where++import           Prelude hiding (seq)++import           Control.Lens hiding (Empty, (:>))+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.State+import           Data.Dynamic+import           Data.IORef+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Maybe+import           Data.Text (Text)+import           Data.Word+import qualified GHC.Stack as GHC+import           Numeric.Natural (Natural)+import           System.IO (Handle, hPutStrLn)++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Classes+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Some+import qualified Data.Vector as V+import qualified Text.LLVM.AST as L++import           What4.Interface+import           What4.Expr( GroundValue )+import           What4.InterpretedFloatingPoint+import           What4.ProgramLoc++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.FunctionHandle+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.ExecutionTree+import           Lang.Crucible.Simulator.GlobalState+import           Lang.Crucible.Simulator.Intrinsics+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.Errors.MemoryError+   (MemErrContext, MemoryErrorReason(..), MemoryOp(..), ppMemoryErrorReason)+import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack)+import qualified Lang.Crucible.LLVM.MemModel.MemLog as ML+import           Lang.Crucible.LLVM.MemModel.Type+import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial+import qualified Lang.Crucible.LLVM.MemModel.Generic as G+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemModel.Options+import           Lang.Crucible.LLVM.MemModel.Value+import           Lang.Crucible.LLVM.Translation.Constant+import           Lang.Crucible.LLVM.Types+import           Lang.Crucible.LLVM.Utils+import           Lang.Crucible.Panic (panic)+++import           GHC.Stack (HasCallStack)++----------------------------------------------------------------------+-- The MemImpl type++newtype BlockSource = BlockSource (IORef Natural)+type GlobalMap sym = Map L.Symbol (SomePointer sym)++nextBlock :: BlockSource -> IO Natural+nextBlock (BlockSource ref) =+  atomicModifyIORef' ref (\n -> (n+1, n))++-- | The implementation of an LLVM memory, containing an+-- allocation-block source, global map, handle map, and heap.+data MemImpl sym =+  MemImpl+  { memImplBlockSource :: BlockSource+  , memImplGlobalMap   :: GlobalMap sym+  , memImplSymbolMap   :: Map Natural L.Symbol -- inverse mapping to 'memImplGlobalMap'+  , memImplHandleMap   :: Map Natural Dynamic+  , memImplHeap        :: G.Mem sym+  }++memEndian :: MemImpl sym -> EndianForm+memEndian = G.memEndian . memImplHeap++memAllocCount :: MemImpl sym -> Int+memAllocCount = G.memAllocCount . memImplHeap++memWriteCount :: MemImpl sym -> Int+memWriteCount = G.memWriteCount . memImplHeap++-- | Produce a fresh empty memory.+--   NB, we start counting allocation blocks at '1'.+--   Block number 0 is reserved for representing raw bitvectors.+emptyMem :: EndianForm -> IO (MemImpl sym)+emptyMem endianness = do+  blkRef <- newIORef 1+  return $ MemImpl (BlockSource blkRef) Map.empty Map.empty Map.empty (G.emptyMem endianness)++-- | Pretty print a memory state to the given handle.+doDumpMem :: IsExprBuilder sym => Handle -> MemImpl sym -> IO ()+doDumpMem h mem = do+  hPutStrLn h (show (G.ppMem (memImplHeap mem)))++----------------------------------------------------------------------+-- Memory operations+--+++-- | Assert that some undefined behavior doesn't occur when performing memory+-- model operations+assertUndefined ::+  (IsSymBackend sym bak, Partial.HasLLVMAnn sym) =>+  bak ->+  CallStack ->+  Pred sym ->+  (UB.UndefinedBehavior (RegValue' sym)) {- ^ The undesirable behavior -} ->+  IO ()+assertUndefined bak callStack p ub =+  do let sym = backendGetSym bak+     p' <- Partial.annotateUB sym callStack ub p+     assert bak p' $ AssertFailureSimError "Undefined behavior encountered" (show (UB.explain ub))+++assertStoreError ::+  (IsSymBackend sym bak, Partial.HasLLVMAnn sym, 1 <= wptr) =>+  bak ->+  MemErrContext sym wptr ->+  MemoryErrorReason ->+  Pred sym ->+  IO ()+assertStoreError bak errCtx rsn p =+  do let sym = backendGetSym bak+     p' <- Partial.annotateME sym errCtx rsn p+     assert bak p' $ AssertFailureSimError "Memory store failed" (show (ppMemoryErrorReason rsn))++instance IsSymInterface sym => IntrinsicClass sym "LLVM_memory" where+  type Intrinsic sym "LLVM_memory" ctx = MemImpl sym++  -- NB: Here we are assuming the global maps of both memories are identical.+  -- This should be the case as memories are only supposed to allocate globals at+  -- startup, not during program execution.  We could check that the maps match,+  -- but that would be expensive...+  muxIntrinsic _sym _iTypes _nm _ p mem1 mem2 =+     do let MemImpl blockSource gMap1 sMap1 hMap1 m1 = mem1+        let MemImpl _blockSource _gMap2 _sMap2 hMap2 m2 = mem2+        --putStrLn "MEM MERGE"+        return $ MemImpl blockSource gMap1 sMap1+                   (Map.union hMap1 hMap2)+                   (G.mergeMem p m1 m2)++  pushBranchIntrinsic _sym _iTypes _nm _ctx mem =+     do let MemImpl nxt gMap sMap hMap m = mem+        --putStrLn "MEM PUSH BRANCH"+        return $ MemImpl nxt gMap sMap hMap $ G.branchMem m++  abortBranchIntrinsic _sym _iTypes _nm _ctx mem =+     do let MemImpl nxt gMap sMap hMap m = mem+        --putStrLn "MEM ABORT BRANCH"+        return $ MemImpl nxt gMap sMap hMap $ G.branchAbortMem m++-- | Top-level evaluation function for LLVM extension statements.+--   LLVM extension statements are used to implement the memory model operations.+llvmStatementExec ::+  (Partial.HasLLVMAnn sym, ?memOpts :: MemOptions) =>+  EvalStmtFunc p sym LLVM+llvmStatementExec stmt cst =+  let simCtx = cst^.stateContext+   in withBackend simCtx $ \bak ->+        runStateT (evalStmt bak stmt) cst++type EvalM p sym ext rtp blocks ret args a =+  StateT (CrucibleState p sym ext rtp blocks ret args) IO a++-- | Actual workhorse function for evaluating LLVM extension statements.+--   The semantics are explicitly organized as a state transformer monad+--   that modifies the global state of the simulator; this captures the+--   memory accessing effects of these statements.+evalStmt :: forall p sym bak ext rtp blocks ret args tp.+  (IsSymBackend sym bak, Partial.HasLLVMAnn sym, GHC.HasCallStack, ?memOpts :: MemOptions) =>+  bak ->+  LLVMStmt (RegEntry sym) tp ->+  EvalM p sym ext rtp blocks ret args (RegValue sym tp)+evalStmt bak = eval+ where+  sym = backendGetSym bak++  getMem :: GlobalVar Mem ->+            EvalM p sym ext rtp blocks ret args (MemImpl sym)+  getMem mvar =+    do gs <- use (stateTree.actFrame.gpGlobals)+       case lookupGlobal mvar gs of+         Just mem -> return mem+         Nothing  ->+           panic "MemModel.evalStmt.getMem"+             [ "Global heap value not initialized."+             , "*** Global heap variable: " ++ show mvar+             ]++  setMem :: GlobalVar Mem ->+            MemImpl sym ->+            EvalM p sym ext rtp blocks ret args ()+  setMem mvar mem = stateTree.actFrame.gpGlobals %= insertGlobal mvar mem++  failedAssert :: String -> String -> EvalM p sym ext rtp blocks ret args a+  failedAssert msg details =+    lift $ addFailedAssertion bak $ AssertFailureSimError msg details++  eval :: LLVMStmt (RegEntry sym) tp ->+          EvalM p sym ext rtp blocks ret args (RegValue sym tp)+  eval (LLVM_PushFrame nm mvar) =+     do mem <- getMem mvar+        let heap' = G.pushStackFrameMem nm (memImplHeap mem)+        setMem mvar mem{ memImplHeap = heap' }++  eval (LLVM_PopFrame mvar) =+     do mem <- getMem mvar+        let heap' = G.popStackFrameMem (memImplHeap mem)+        setMem mvar mem{ memImplHeap = heap' }++  eval (LLVM_Alloca _w mvar (regValue -> sz) alignment loc) =+     do mem <- getMem mvar+        (ptr, mem') <- liftIO $ doAlloca bak mem sz alignment loc+        setMem mvar mem'+        return ptr++  eval (LLVM_Load mvar (regValue -> ptr) tpr valType alignment) =+     do mem <- getMem mvar+        liftIO $ doLoad bak mem ptr valType tpr alignment++  eval (LLVM_MemClear mvar (regValue -> ptr) bytes) =+    do mem <- getMem mvar+       z   <- liftIO $ bvLit sym knownNat (BV.zero knownNat)+       len <- liftIO $ bvLit sym PtrWidth (bytesToBV PtrWidth bytes)+       mem' <- liftIO $ doMemset bak PtrWidth mem ptr z len+       setMem mvar mem'++  eval (LLVM_Store mvar (regValue -> ptr) tpr valType alignment (regValue -> val)) =+     do mem <- getMem mvar+        mem' <- liftIO $ doStore bak mem ptr tpr valType alignment val+        setMem mvar mem'++  eval (LLVM_LoadHandle mvar ltp (regValue -> ptr) args ret) =+     do mem <- getMem mvar+        let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+        mhandle <- liftIO $ doLookupHandle sym mem ptr+        let mop = MemLoadHandleOp ltp gsym ptr (memImplHeap mem)+        let expectedTp = FunctionHandleRepr args ret+        case mhandle of+           Left lookupErr -> lift $+             do p <- Partial.annotateME sym mop (BadFunctionPointer lookupErr) (falsePred sym)+                loc <- getCurrentProgramLoc sym+                let err = SimError loc (AssertFailureSimError "Failed to load function handle" (show (ME.ppFuncLookupError lookupErr)))+                addProofObligation bak (LabeledPred p err)+                abortExecBecause (AssertionFailure err)++           Right (VarargsFnHandle h) ->+             let err = failedAssert "Failed to load function handle"+                  (unlines+                   ["Expected function handle of type " <> show expectedTp+                   ,"for call to function " <> show (handleName h)+                   ,"but found varargs handle of non-matching type " ++ show (handleType h)+                   ]) in+             case handleArgTypes h of+               prefix Ctx.:> VectorRepr AnyRepr+                 | Just Refl <- testEquality ret (handleReturnType h)+                 -> Ctx.dropPrefix args prefix err (return . VarargsFnVal h)++               _ -> err++           Right (SomeFnHandle h)+             | Just Refl <- testEquality (handleType h) expectedTp -> return (HandleFnVal h)+             | otherwise -> failedAssert+                 "Failed to load function handle"+                 (unlines ["Expected function handle of type " <> show expectedTp+                          , "for call to function " <> show (handleName h)+                          , "but found calling handle of type " ++ show (handleType h)])++  eval (LLVM_ResolveGlobal _w mvar (GlobalSymbol symbol)) =+     do mem <- getMem mvar+        liftIO $ doResolveGlobal bak mem symbol++  eval (LLVM_PtrEq mvar (regValue -> x) (regValue -> y)) = do+     mem <- getMem mvar+     liftIO $ do+        v1 <- isValidPointer sym x mem+        v2 <- isValidPointer sym y mem+        v3 <- G.notAliasable sym x y (memImplHeap mem)++        let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+        assertUndefined bak callStack v1 $+          UB.CompareInvalidPointer UB.Eq (RV x) (RV y)+        assertUndefined bak callStack v2 $+          UB.CompareInvalidPointer UB.Eq (RV x) (RV y)++        unless (laxConstantEquality ?memOpts) $+          do let allocs_doc = G.ppAllocs (G.memAllocs (memImplHeap mem))+             let x_doc = G.ppPtr x+             let y_doc = G.ppPtr y+             -- TODO: Is this undefined behavior? If so, add to the UB module+             assert bak v3 $+               AssertFailureSimError+               "Const pointers compared for equality"+               (unlines [ show x_doc+                        , show y_doc+                        , show allocs_doc+                        ])+        ptrEq sym PtrWidth x y++  eval (LLVM_PtrLe mvar (regValue -> x) (regValue -> y)) = do+    mem <- getMem mvar+    liftIO $ do+       v1 <- isValidPointer sym x mem+       v2 <- isValidPointer sym y mem++       let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+       assertUndefined bak callStack v1+        (UB.CompareInvalidPointer UB.Leq (RV x) (RV y))+       assertUndefined bak callStack v2+        (UB.CompareInvalidPointer UB.Leq (RV x) (RV y))++       (le, valid) <- ptrLe sym PtrWidth x y+       assertUndefined bak callStack valid+         (UB.CompareDifferentAllocs (RV x) (RV y))++       pure le++  eval (LLVM_PtrAddOffset _w mvar (regValue -> x) (regValue -> y)) =+    do mem <- getMem mvar+       liftIO $ doPtrAddOffset bak mem x y++  eval (LLVM_PtrSubtract _w mvar (regValue -> x) (regValue -> y)) =+    do mem <- getMem mvar+       liftIO $ doPtrSubtract bak mem x y++  eval LLVM_Debug{} = pure ()+++mkMemVar :: Text+         -> HandleAllocator+         -> IO (GlobalVar Mem)+mkMemVar memName halloc = freshGlobalVar halloc memName knownRepr+++-- | For now, the core message should be on the first line, with details+-- on further lines. Later we should make it more structured.+ptrMessage ::+  (IsSymInterface sym) =>+  String ->+  LLVMPtr sym wptr {- ^ pointer involved in message -} ->+  StorageType      {- ^ type of value pointed to    -} ->+  String+ptrMessage msg ptr ty =+  unlines [ msg+          , "  address " ++ show (G.ppPtr ptr)+          , "  at type " ++ show (G.ppType ty)+          ]++-- | Allocate memory on the stack frame of the currently executing function.+doAlloca ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  SymBV sym wptr {- ^ allocation size -} ->+  Alignment      {- ^ pointer alignment -} ->+  String         {- ^ source location for use in error messages -} ->+  IO (LLVMPtr sym wptr, MemImpl sym)+doAlloca bak mem sz alignment loc = do+  let sym = backendGetSym bak+  blkNum <- liftIO $ nextBlock (memImplBlockSource mem)+  blk <- liftIO $ natLit sym blkNum+  z <- liftIO $ bvLit sym PtrWidth (BV.zero PtrWidth)++  let heap' = G.allocMem G.StackAlloc blkNum (Just sz) alignment G.Mutable loc (memImplHeap mem)+  let ptr   = LLVMPointer blk z+  let mem'  = mem{ memImplHeap = heap' }+  mem'' <- if laxLoadsAndStores ?memOpts+                && indeterminateLoadBehavior ?memOpts == StableSymbolic+           then doConstStoreStableSymbolic bak mem' ptr (Just sz) alignment+           else pure mem'+  pure (ptr, mem'')++-- | Load a 'RegValue' from memory. Both the 'StorageType' and 'TypeRepr'+-- arguments should be computed from a single 'MemType' using+-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr'+-- respectively.+--+-- Precondition: the pointer is valid and aligned, and the loaded value is defined.+doLoad ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ pointer to load from      -} ->+  StorageType      {- ^ type of value to load     -} ->+  TypeRepr tp      {- ^ crucible type of the result -} ->+  Alignment        {- ^ assumed pointer alignment -} ->+  IO (RegValue sym tp)+doLoad bak mem ptr valType tpr alignment = do+  let sym = backendGetSym bak+  unpackMemValue sym tpr =<<+    Partial.assertSafe bak =<<+      loadRaw sym mem ptr valType alignment++-- | Store a 'RegValue' in memory. Both the 'StorageType' and 'TypeRepr'+-- arguments should be computed from a single 'MemType' using+-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr'+-- respectively.+--+-- Precondition: the pointer is valid and points to a mutable memory region.+doStore ::+  ( IsSymBackend sym bak+  , HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ pointer to store into  -} ->+  TypeRepr tp ->+  StorageType      {- ^ type of value to store -} ->+  Alignment ->+  RegValue sym tp  {- ^ value to store         -} ->+  IO (MemImpl sym)+doStore bak mem ptr tpr valType alignment val = do+    --putStrLn "MEM STORE"+    let sym = backendGetSym bak+    val' <- packMemValue sym valType tpr val+    storeRaw bak mem ptr valType alignment val'++data SomeFnHandle where+  SomeFnHandle    :: FnHandle args ret -> SomeFnHandle+  VarargsFnHandle :: FnHandle (args ::> VectorType AnyType) ret -> SomeFnHandle++sextendBVTo :: (1 <= w, 1 <= w', IsSymInterface sym)+            => sym+            -> NatRepr w+            -> NatRepr w'+            -> SymExpr sym (BaseBVType w)+            -> IO (SymExpr sym (BaseBVType w'))+sextendBVTo sym w w' x+  | Just Refl <- testEquality w w' = return x+  | Just LeqProof <- testLeq (incNat w) w' = bvSext sym w' x+  | Just LeqProof <- testLeq (incNat w') w = bvTrunc sym w' x+  | otherwise = panic "sextendBVTo"+                  [ "Impossible widths!"+                  , show w+                  , show w'+                  ]++-- | Allocate and zero a memory region with /size * number/ bytes.+--+-- Precondition: the multiplication /size * number/ does not overflow.+doCalloc ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  SymBV sym wptr {- ^ size   -} ->+  SymBV sym wptr {- ^ number -} ->+  Alignment {- ^ Minimum alignment of the resulting allocation -} ->+  IO (LLVMPtr sym wptr, MemImpl sym)+doCalloc bak mem sz num alignment = do+  let sym = backendGetSym bak+  (ov, sz') <- unsignedWideMultiplyBV sym sz num+  ov_iszero <- notPred sym =<< bvIsNonzero sym ov+  -- TODO, this probably shouldn't be UB+  assert bak ov_iszero+     (AssertFailureSimError "Multiplication overflow in calloc()" "")++  loc <- plSourceLoc <$> getCurrentProgramLoc sym+  let displayString = "<calloc> " ++ show loc+  z <- bvLit sym knownNat (BV.zero knownNat)+  (ptr, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz' alignment+  mem'' <- doMemset bak PtrWidth mem' ptr z sz'+  return (ptr, mem'')++-- | Allocate a memory region.+doMalloc+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> G.AllocType {- ^ stack, heap, or global -}+  -> G.Mutability {- ^ whether region is read-only -}+  -> String {- ^ source location for use in error messages -}+  -> MemImpl sym+  -> SymBV sym wptr {- ^ allocation size -}+  -> Alignment+  -> IO (LLVMPtr sym wptr, MemImpl sym)+doMalloc bak allocType mut loc mem sz alignment = doMallocSize (Just sz) bak allocType mut loc mem alignment++-- | Allocate a memory region of unbounded size.+doMallocUnbounded+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> G.AllocType {- ^ stack, heap, or global -}+  -> G.Mutability {- ^ whether region is read-only -}+  -> String {- ^ source location for use in error messages -}+  -> MemImpl sym+  -> Alignment+  -> IO (LLVMPtr sym wptr, MemImpl sym)+doMallocUnbounded = doMallocSize Nothing++doMallocSize+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => Maybe (SymBV sym wptr) {- ^ allocation size -}+  -> bak+  -> G.AllocType {- ^ stack, heap, or global -}+  -> G.Mutability {- ^ whether region is read-only -}+  -> String {- ^ source location for use in error messages -}+  -> MemImpl sym+  -> Alignment+  -> IO (LLVMPtr sym wptr, MemImpl sym)+doMallocSize sz bak allocType mut loc mem alignment = do+  let sym = backendGetSym bak+  blkNum <- nextBlock (memImplBlockSource mem)+  blk    <- natLit sym blkNum+  z      <- bvLit sym PtrWidth (BV.zero PtrWidth)+  let heap' = G.allocMem allocType blkNum sz alignment mut loc (memImplHeap mem)+  let ptr   = LLVMPointer blk z+  let mem'  = mem{ memImplHeap = heap' }+  mem'' <- if laxLoadsAndStores ?memOpts+                && allocType == G.HeapAlloc+                && indeterminateLoadBehavior ?memOpts == StableSymbolic+           then doConstStoreStableSymbolic bak mem' ptr sz alignment+           else pure mem'+  return (ptr, mem'')++++bindLLVMFunPtr ::+  (IsSymBackend sym bak, HasPtrWidth wptr) =>+  bak ->+  L.Symbol ->+  FnHandle args ret ->+  MemImpl sym ->+  IO (MemImpl sym)+bindLLVMFunPtr bak nm h mem+  | (_ Ctx.:> VectorRepr AnyRepr) <- handleArgTypes h++  = do ptr <- doResolveGlobal bak mem nm+       doInstallHandle bak ptr (VarargsFnHandle h) mem++  | otherwise+  = do ptr <- doResolveGlobal bak mem nm+       doInstallHandle bak ptr (SomeFnHandle h) mem++doInstallHandle+  :: (Typeable a, IsSymBackend sym bak)+  => bak+  -> LLVMPtr sym wptr+  -> a {- ^ handle -}+  -> MemImpl sym+  -> IO (MemImpl sym)+doInstallHandle _bak ptr x mem =+  case asNat (llvmPointerBlock ptr) of+    Just blkNum ->+      do let hMap' = Map.insert blkNum (toDyn x) (memImplHandleMap mem)+         return mem{ memImplHandleMap = hMap' }+    Nothing ->+      panic "MemModel.doInstallHandle"+        [ "Attempted to install handle for symbolic pointer"+        , "  " ++ show (ppPtr ptr)+        ]++-- | Allocate a memory region for the given handle.+doMallocHandle+  :: (Typeable a, IsSymInterface sym, HasPtrWidth wptr)+  => sym+  -> G.AllocType {- ^ stack, heap, or global -}+  -> String {- ^ source location for use in error messages -}+  -> MemImpl sym+  -> a {- ^ handle -}+  -> IO (LLVMPtr sym wptr, MemImpl sym)+doMallocHandle sym allocType loc mem x = do+  blkNum <- nextBlock (memImplBlockSource mem)+  blk <- natLit sym blkNum+  z <- bvLit sym PtrWidth (BV.zero PtrWidth)++  let heap' = G.allocMem allocType blkNum (Just z) noAlignment G.Immutable loc (memImplHeap mem)+  let hMap' = Map.insert blkNum (toDyn x) (memImplHandleMap mem)+  let ptr = LLVMPointer blk z+  return (ptr, mem{ memImplHeap = heap', memImplHandleMap = hMap' })++-- | Look up the handle associated with the given pointer, if any.+doLookupHandle+  :: (Typeable a, IsSymInterface sym)+  => sym+  -> MemImpl sym+  -> LLVMPtr sym wptr+  -> IO (Either ME.FuncLookupError a)+doLookupHandle _sym mem ptr = do+  let LLVMPointer blk _ = ptr+  case asNat blk of+    Nothing -> return (Left ME.SymbolicPointer)+    Just i+      | i == 0 -> return (Left ME.RawBitvector)+      | otherwise ->+          case Map.lookup i (memImplHandleMap mem) of+            Nothing -> return (Left ME.NoOverride)+            Just x ->+              case fromDynamic x of+                Nothing -> return (Left (ME.Uncallable (dynTypeRep x)))+                Just a  -> return (Right a)++-- | Free the memory region pointed to by the given pointer.+--+-- Precondition: the pointer either points to the beginning of an allocated+-- region, or is null. Freeing a null pointer has no effect.+doFree+  :: (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym wptr+  -> IO (MemImpl sym)+doFree bak mem ptr = do+  let sym = backendGetSym bak+  let LLVMPointer blk _off = ptr+  loc <- show . plSourceLoc <$> getCurrentProgramLoc sym+  (heap', p1, p2, notFreed) <- G.freeMem sym PtrWidth ptr (memImplHeap mem) loc++  -- If this pointer is a handle pointer, remove the associated data+  let hMap' =+       case asNat blk of+         Just i  -> Map.delete i (memImplHandleMap mem)+         Nothing -> memImplHandleMap mem++  -- NB: free is defined and has no effect if passed a null pointer+  isNull    <- ptrIsNull sym PtrWidth ptr+  p1'       <- orPred sym p1 isNull+  p2'       <- orPred sym p2 isNull+  notFreed' <- orPred sym notFreed isNull+  let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+  assertUndefined bak callStack p1' (UB.FreeBadOffset (RV ptr))+  assertUndefined bak callStack p2' (UB.FreeUnallocated (RV ptr))+  assertUndefined bak callStack notFreed' (UB.DoubleFree (RV ptr))++  return mem{ memImplHeap = heap', memImplHandleMap = hMap' }++-- | Fill a memory range with copies of the specified byte.+--+-- Precondition: the memory range falls within a valid allocated region.+doMemset ::+  (1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>+  bak ->+  NatRepr w ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ destination -} ->+  SymBV sym 8      {- ^ fill byte   -} ->+  SymBV sym w      {- ^ length      -} ->+  IO (MemImpl sym)+doMemset bak w mem dest val len = do+  let sym = backendGetSym bak+  len' <- sextendBVTo sym w PtrWidth len++  (heap', p) <- G.setMem sym PtrWidth dest val len' (memImplHeap mem)++  let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+  assertUndefined bak callStack p $+    UB.MemsetInvalidRegion (RV dest) (RV val) (RV len)++  return mem{ memImplHeap = heap' }++doInvalidate ::+  ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  NatRepr w ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ destination -} ->+  Text             {- ^ message     -} ->+  SymBV sym w      {- ^ length      -} ->+  IO (MemImpl sym)+doInvalidate bak w mem dest msg len = do+  let sym = backendGetSym bak+  len' <- sextendBVTo sym w PtrWidth len++  (heap', p) <- if laxLoadsAndStores ?memOpts &&+                   indeterminateLoadBehavior ?memOpts == StableSymbolic+                then do p <- G.isAllocatedMutable sym PtrWidth noAlignment dest (Just len') (memImplHeap mem)+                        mem' <- doStoreStableSymbolic bak mem dest (Just len') noAlignment+                        pure (memImplHeap mem', p)+                else G.invalidateMem sym PtrWidth dest msg len' (memImplHeap mem)++  let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) dest+  let mop = MemInvalidateOp msg gsym dest len (memImplHeap mem)+  p' <- Partial.annotateME sym mop UnwritableRegion p+  assert bak p' $ AssertFailureSimError "Invalidation of unallocated or readonly region" ""++  return mem{ memImplHeap = heap' }++-- | Store an array in memory.+--+-- Precondition: the pointer is valid and points to a mutable memory region.+doArrayStore+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> SymBV sym w {- ^ array length -}+  -> IO (MemImpl sym)+doArrayStore bak mem ptr alignment arr len = doArrayStoreSize (Just len) bak mem ptr alignment arr++-- | Store an array of unbounded length in memory.+--+-- Precondition: the pointer is valid and points to a mutable memory region.+doArrayStoreUnbounded+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> IO (MemImpl sym)+doArrayStoreUnbounded = doArrayStoreSize Nothing+++doArrayStoreSize+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -}+  -> bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> IO (MemImpl sym)+doArrayStoreSize len bak mem ptr alignment arr = do+  let sym = backendGetSym bak+  (heap', p1, p2) <-+    G.writeArrayMem sym PtrWidth ptr alignment arr len (memImplHeap mem)++  let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+  let mop = MemStoreBytesOp gsym ptr len (memImplHeap mem)++  assertStoreError bak mop UnwritableRegion p1+  let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+  assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment)++  return mem { memImplHeap = heap' }++-- | Store an array in memory.+--+-- Precondition: the pointer is valid and points to a mutable or immutable memory region.+-- Therefore it can be used to initialize read-only memory regions.+doArrayConstStore+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> SymBV sym w {- ^ array length -}+  -> IO (MemImpl sym)+doArrayConstStore bak mem ptr alignment arr len =+  doArrayConstStoreSize (Just len) bak mem ptr alignment arr++-- | Store an array of unbounded length in memory.+--+-- Precondition: the pointer is valid and points to a mutable or immutable memory region.+-- Therefore it can be used to initialize read-only memory regions.+doArrayConstStoreUnbounded+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> IO (MemImpl sym)+doArrayConstStoreUnbounded = doArrayConstStoreSize Nothing++-- | The workhorse for 'doArrayConstStore' (if the first argument is+-- @'Just' len@) or 'doArrayConstStoreUnbounded' (if the first argument is+-- 'Nothing').+doArrayConstStoreSize+  :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym)+  => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -}+  -> bak+  -> MemImpl sym+  -> LLVMPtr sym w {- ^ destination  -}+  -> Alignment+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value  -}+  -> IO (MemImpl sym)+doArrayConstStoreSize len bak mem ptr alignment arr = do+  let sym = backendGetSym bak+  (heap', p1, p2) <-+    G.writeArrayConstMem sym PtrWidth ptr alignment arr len (memImplHeap mem)++  let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+  let mop = MemStoreBytesOp gsym ptr len (memImplHeap mem)++  assertStoreError bak mop UnwritableRegion p1+  let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+  assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment)++  return mem { memImplHeap = heap' }++-- | Copy memory from source to destination.+--+-- Precondition: the source and destination pointers fall within valid allocated+-- regions.+doMemcpy ::+  ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  NatRepr w ->+  MemImpl sym ->+  Bool {- ^ if true, require disjoint memory regions -} ->+  LLVMPtr sym wptr {- ^ destination -} ->+  LLVMPtr sym wptr {- ^ source      -} ->+  SymBV sym w      {- ^ length      -} ->+  IO (MemImpl sym)+doMemcpy bak w mem mustBeDisjoint dest src len = do+  let sym = backendGetSym bak+  len' <- sextendBVTo sym w PtrWidth len++  (heap', p1, p2) <- G.copyMem sym PtrWidth dest src len' (memImplHeap mem)++  let gsym_dest = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) dest+  let gsym_src = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) src++  let mop = MemCopyOp (gsym_dest, dest) (gsym_src, src) len (memImplHeap mem)++  p1' <- applyUnless (laxLoadsAndStores ?memOpts)+                     (Partial.annotateME sym mop UnreadableRegion) p1+  p2' <- Partial.annotateME sym mop UnwritableRegion p2++  assert bak p1' $ AssertFailureSimError "Mem copy failed" "Invalid copy source"+  assert bak p2' $ AssertFailureSimError "Mem copy failed" "Invalid copy destination"++  when mustBeDisjoint (assertDisjointRegions bak mop (bvWidth len) dest len src len)++  return mem{ memImplHeap = heap' }++unsymbol :: L.Symbol -> String+unsymbol (L.Symbol s) = s++-- | Copy memory from source to destination.  This version does+--   no checks to verify that the source and destination allocations+--   are allocated and appropriately sized.+uncheckedMemcpy ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  sym ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ destination -} ->+  LLVMPtr sym wptr {- ^ source      -} ->+  SymBV sym wptr   {- ^ length      -} ->+  IO (MemImpl sym)+uncheckedMemcpy sym mem dest src len = do+  (heap', _p1, _p2) <- G.copyMem sym PtrWidth dest src len (memImplHeap mem)+  return mem{ memImplHeap = heap' }++doPtrSubtract ::+  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr ->+  LLVMPtr sym wptr ->+  IO (SymBV sym wptr)+doPtrSubtract bak mem x y = do+  let sym = backendGetSym bak+  (diff, valid) <- ptrDiff sym PtrWidth x y+  let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+  assertUndefined bak callStack valid $+    UB.PtrSubDifferentAllocs (RV x) (RV y)+  pure diff++-- | Add an offset to a pointer and asserts that the result is a valid pointer.+doPtrAddOffset ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr {- ^ base pointer -} ->+  SymBV sym wptr   {- ^ offset       -} ->+  IO (LLVMPtr sym wptr)+doPtrAddOffset bak m x@(LLVMPointer blk _) off = do+  let sym = backendGetSym bak+  isBV <- natEq sym blk =<< natLit sym 0+  x' <- ptrAdd sym PtrWidth x off+  v <- case asConstantPred isBV of+         Just True  -> return isBV+         _ -> orPred sym isBV =<< G.isValidPointer sym PtrWidth x' (memImplHeap m)+  unless (laxLoadsAndStores ?memOpts) $+    let callStack = getCallStack (m ^. to memImplHeap . ML.memState)+    in assertUndefined bak callStack v (UB.PtrAddOffsetOutOfBounds (RV x) (RV off))+  return x'++-- | Store a fresh symbolic value of the appropriate size in the supplied+-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is+-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'.+doStoreStableSymbolic ::+  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr       {- ^ destination       -} ->+  Maybe (SymBV sym wptr) {- ^ allocation size   -} ->+  Alignment              {- ^ pointer alignment -} ->+  IO (MemImpl sym)+doStoreStableSymbolic bak mem ptr mbSz alignment = do+  let sym = backendGetSym bak+  bytes <- freshConstant sym emptySymbol+             (BaseArrayRepr (Ctx.singleton (BaseBVRepr ?ptrWidth))+                            (BaseBVRepr (knownNat @8)))+  case mbSz of+    Just sz -> doArrayStore bak mem ptr alignment bytes sz+    Nothing -> doArrayStoreUnbounded bak mem ptr alignment bytes++-- | Store a fresh symbolic value of the appropriate size in the supplied+-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is+-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'.+--+-- Precondition: the pointer is valid and points to a mutable or immutable+-- memory region. Therefore it can be used to initialize read-only memory+-- regions.+doConstStoreStableSymbolic ::+  (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) =>+  bak ->+  MemImpl sym ->+  LLVMPtr sym wptr       {- ^ destination       -} ->+  Maybe (SymBV sym wptr) {- ^ allocation size   -} ->+  Alignment              {- ^ pointer alignment -} ->+  IO (MemImpl sym)+doConstStoreStableSymbolic bak mem ptr mbSz alignment = do+  let sym = backendGetSym bak+  bytes <- freshConstant sym emptySymbol+             (BaseArrayRepr (Ctx.singleton (BaseBVRepr ?ptrWidth))+                            (BaseBVRepr (knownNat @8)))+  case mbSz of+    Just sz -> doArrayConstStore bak mem ptr alignment bytes sz+    Nothing -> doArrayConstStoreUnbounded bak mem ptr alignment bytes++-- | This predicate tests if the pointer is a valid, live pointer+--   into the heap, OR is the distinguished NULL pointer.+isValidPointer ::+  (IsSymInterface sym, HasPtrWidth wptr) =>+  sym ->+  LLVMPtr sym wptr ->+  MemImpl sym ->+  IO (Pred sym)+isValidPointer sym p mem =+   do np <- ptrIsNull sym PtrWidth p+      case asConstantPred np of+        Just True  -> return np+        Just False -> G.isValidPointer sym PtrWidth p (memImplHeap mem)+        _ -> orPred sym np =<< G.isValidPointer sym PtrWidth p (memImplHeap mem)++-- | Return the condition required to prove that the pointer points to+-- a range of 'size' bytes that falls within an allocated region of+-- the appropriate mutability, and also that the pointer is+-- sufficiently aligned.+isAllocatedAlignedPointer ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  Alignment           {- ^ minimum required pointer alignment                 -} ->+  G.Mutability        {- ^ 'Mutable' means pointed-to region must be writable -} ->+  LLVMPtr sym w       {- ^ pointer                                            -} ->+  Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space)        -} ->+  MemImpl sym         {- ^ memory                                             -} ->+  IO (Pred sym)+isAllocatedAlignedPointer sym w alignment mutability ptr size mem =+  G.isAllocatedAlignedPointer sym w alignment mutability ptr size (memImplHeap mem)++-- | Compute the length of a null-terminated string.+--+--   The pointer to read from must be concrete and nonnull.  The contents+--   of the string may be symbolic; HOWEVER, this function will not terminate+--   until it eventually reaches a concete null-terminator or a load error.+strLen ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym      {- ^ memory to read from        -} ->+  LLVMPtr sym wptr {- ^ pointer to string value    -} ->+  IO (SymBV sym wptr)+strLen bak mem = go (BV.zero PtrWidth) (truePred sym)+  where+  sym = backendGetSym bak++  go !n cond p =+    loadRaw sym mem p (bitvectorType 1) noAlignment >>= \case+      Partial.Err pe ->+        do ast <- impliesPred sym cond pe+           assert bak ast $ AssertFailureSimError "Error during memory load: strlen" ""+           bvLit sym PtrWidth (BV.zero PtrWidth) -- bogus value, but have to return something...+      Partial.NoErr loadok llvmval ->+        do ast <- impliesPred sym cond loadok+           assert bak ast $ AssertFailureSimError "Error during memory load: strlen" ""+           v <- unpackMemValue sym (LLVMPointerRepr (knownNat @8)) llvmval+           test <- bvIsNonzero sym =<< Partial.projectLLVM_bv bak v+           iteM bvIte sym+             test+             (do cond' <- andPred sym cond test+                 p'    <- doPtrAddOffset bak mem p =<< bvLit sym PtrWidth (BV.one PtrWidth)+                 case BV.succUnsigned PtrWidth n of+                   Just n_1 -> go n_1 cond' p'+                   Nothing -> panic "Lang.Crucible.LLVM.MemModel.strLen" ["string length exceeds pointer width"])+             (bvLit sym PtrWidth n)+++-- | Load a null-terminated string from the memory.+--+-- The pointer to read from must be concrete and nonnull.  Moreover,+-- we require all the characters in the string to be concrete.+-- Otherwise it is very difficult to tell when the string has+-- terminated.  If a maximum number of characters is provided, no more+-- than that number of charcters will be read.  In either case,+-- `loadString` will stop reading if it encounters a null-terminator.+loadString :: forall sym bak wptr.+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions, GHC.HasCallStack ) =>+  bak ->+  MemImpl sym      {- ^ memory to read from        -} ->+  LLVMPtr sym wptr {- ^ pointer to string value    -} ->+  Maybe Int        {- ^ maximum characters to read -} ->+  IO [Word8]+loadString bak mem = go id+ where+  sym = backendGetSym bak++  go :: ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8]+  go f _ (Just 0) = return $ f []+  go f p maxChars = do+     v <- doLoad bak mem p (bitvectorType 1) (LLVMPointerRepr (knownNat :: NatRepr 8)) noAlignment+     x <- Partial.projectLLVM_bv bak v+     case BV.asUnsigned <$> asBV x of+       Just 0 -> return $ f []+       Just c -> do+           let c' :: Word8 = toEnum $ fromInteger c+           p' <- doPtrAddOffset bak mem p =<< bvLit sym PtrWidth (BV.one PtrWidth)+           go (f . (c':)) p' (fmap (\n -> n - 1) maxChars)+       Nothing ->+         addFailedAssertion bak+            $ Unsupported GHC.callStack "Symbolic value encountered when loading a string"++-- | Like 'loadString', except the pointer to load may be null.  If+--   the pointer is null, we return Nothing.  Otherwise we load+--   the string as with 'loadString' and return it.+loadMaybeString ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions, GHC.HasCallStack ) =>+  bak ->+  MemImpl sym      {- ^ memory to read from        -} ->+  LLVMPtr sym wptr {- ^ pointer to string value    -} ->+  Maybe Int        {- ^ maximum characters to read -} ->+  IO (Maybe [Word8])+loadMaybeString bak mem ptr n = do+  let sym = backendGetSym bak+  isnull <- ptrIsNull sym PtrWidth ptr+  case asConstantPred isnull of+    Nothing    -> addFailedAssertion bak+                    $ Unsupported GHC.callStack "Symbolic pointer encountered when loading a string"+    Just True  -> return Nothing+    Just False -> Just <$> loadString bak mem ptr n+++toStorableType :: (MonadFail m, HasPtrWidth wptr)+               => MemType+               -> m StorageType+toStorableType mt =+  case mt of+    IntType n -> return $ bitvectorType (bitsToBytes n)+    PtrType _ -> return $ bitvectorType (bitsToBytes (natValue PtrWidth))+    PtrOpaqueType -> return $ bitvectorType (bitsToBytes (natValue PtrWidth))+    FloatType -> return $ floatType+    DoubleType -> return $ doubleType+    X86_FP80Type -> return $ x86_fp80Type+    ArrayType n x -> arrayType (fromIntegral n) <$> toStorableType x+    VecType n x -> arrayType (fromIntegral n) <$> toStorableType x+    MetadataType -> fail "toStorableType: Cannot store metadata values"+    StructType si -> mkStructType <$> traverse transField (siFields si)+      where transField :: MonadFail m => FieldInfo -> m (StorageType, Bytes)+            transField fi = do+               t <- toStorableType $ fiType fi+               return (t, fiPadding fi)++----------------------------------------------------------------------+-- "Raw" operations+--++-- | Load an LLVM value from memory. Asserts that the pointer is valid and the+-- result value is not undefined.+loadRaw :: ( IsSymInterface sym, HasPtrWidth wptr, Partial.HasLLVMAnn sym+           , ?memOpts :: MemOptions )+        => sym+        -> MemImpl sym+        -> LLVMPtr sym wptr+        -> StorageType+        -> Alignment+        -> IO (Partial.PartLLVMVal sym)+loadRaw sym mem ptr valType alignment = do+  let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+  G.readMem sym PtrWidth gsym ptr valType alignment (memImplHeap mem)++-- | Store an LLVM value in memory. Asserts that the pointer is valid and points+-- to a mutable memory region.+storeRaw ::+     ( IsSymBackend sym bak+     , HasPtrWidth wptr+     , Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> MemImpl sym+  -> LLVMPtr sym wptr {- ^ pointer to store into -}+  -> StorageType      {- ^ type of value to store -}+  -> Alignment+  -> LLVMVal sym      {- ^ value to store -}+  -> IO (MemImpl sym)+storeRaw bak mem ptr valType alignment val = do+    let sym = backendGetSym bak+    let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+    (heap', p1, p2) <- G.writeMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem)++    let mop = MemStoreOp valType gsym ptr (memImplHeap mem)++    assertStoreError bak mop UnwritableRegion p1+    let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+    assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment)++    return mem{ memImplHeap = heap' }++-- | Perform a memory write operation if the condition is true,+-- do not change the memory otherwise.+--+-- Asserts that the write operation is valid when cond is true.+doConditionalWriteOperation+  :: (IsSymBackend sym bak)+  => bak+  -> MemImpl sym+  -> Pred sym {- ^ write condition -}+  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ memory write operation -}+  -> IO (MemImpl sym)+doConditionalWriteOperation bak mem cond write_op =+  mergeWriteOperations bak mem cond write_op return++-- | Merge memory write operations on condition: if the condition is true,+-- perform the true branch write operation, otherwise perform the false branch+-- write operation.+--+-- Asserts that the true branch write operation is valid when cond is true, and+-- that the false branch write operation is valid when cond is not true.+mergeWriteOperations+  :: (IsSymBackend sym bak)+  => bak+  -> MemImpl sym+  -> Pred sym {- ^ merge condition -}+  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ true branch memory write operation -}+  -> (MemImpl sym -> IO (MemImpl sym)) {- ^ false branch memory write operation -}+  -> IO (MemImpl sym)+mergeWriteOperations bak mem cond true_write_op false_write_op = do+  let sym = backendGetSym bak+  let branched_mem = mem { memImplHeap = G.branchMem $ memImplHeap mem }+  loc <- getCurrentProgramLoc sym++  true_frame_id <- pushAssumptionFrame bak+  addAssumption bak (GenericAssumption loc "conditional memory write predicate" cond)+  true_mutated_heap <- memImplHeap <$> true_write_op branched_mem+  _ <- popAssumptionFrame bak true_frame_id++  false_frame_id <- pushAssumptionFrame bak+  not_cond <- notPred sym cond+  addAssumption bak (GenericAssumption loc "conditional memory write predicate" not_cond)+  false_mutated_heap <- memImplHeap <$> false_write_op branched_mem+  _ <- popAssumptionFrame bak false_frame_id++  return $!+    mem { memImplHeap = G.mergeMem cond true_mutated_heap false_mutated_heap }++-- | Store an LLVM value in memory if the condition is true, and+-- otherwise leaves memory unchanged.+--+-- Asserts that the pointer is valid and points to a mutable memory+-- region when cond is true.+condStoreRaw ::+     ( IsSymBackend sym bak+     , HasPtrWidth wptr+     , Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions+     )+  => bak+  -> MemImpl sym+  -> Pred sym {- ^ Predicate that determines if we actually write. -}+  -> LLVMPtr sym wptr {- ^ pointer to store into -}+  -> StorageType      {- ^ type of value to store -}+  -> Alignment+  -> LLVMVal sym      {- ^ value to store -}+  -> IO (MemImpl sym)+condStoreRaw bak mem cond ptr valType alignment val = do+  let sym = backendGetSym bak+  let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+  -- Get current heap+  let preBranchHeap = memImplHeap mem+  -- Push a branch to the heap+  let postBranchHeap = G.branchMem preBranchHeap++  let mop = MemStoreOp valType gsym ptr preBranchHeap++  -- Write to the heap+  (postWriteHeap, isAllocated, isAligned) <- G.writeMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem)+  -- Assert is allocated if write executes+  do condIsAllocated <- impliesPred sym cond isAllocated+     assertStoreError bak mop UnwritableRegion condIsAllocated+  -- Assert is aligned if write executes+  do condIsAligned <- impliesPred sym cond isAligned+     let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+     assertUndefined bak callStack condIsAligned (UB.WriteBadAlignment (RV ptr) alignment)+  -- Merge the write heap and non-write heap+  let mergedHeap = G.mergeMem cond postWriteHeap postBranchHeap+  -- Return new memory+  return $! mem{ memImplHeap = mergedHeap }++-- | Store an LLVM value in memory. The pointed-to memory region may+-- be either mutable or immutable; thus 'storeConstRaw' can be used to+-- initialize read-only memory regions.+storeConstRaw ::+     ( IsSymBackend sym bak+     , HasPtrWidth wptr+     , Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> MemImpl sym+  -> LLVMPtr sym wptr {- ^ pointer to store into -}+  -> StorageType      {- ^ type of value to store -}+  -> Alignment+  -> LLVMVal sym      {- ^ value to store -}+  -> IO (MemImpl sym)+storeConstRaw bak mem ptr valType alignment val = do+    let sym = backendGetSym bak+    let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr+    (heap', p1, p2) <- G.writeConstMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem)++    let mop = MemStoreOp valType gsym ptr (memImplHeap mem)++    assertStoreError bak mop UnwritableRegion p1+    let callStack = getCallStack (mem ^. to memImplHeap . ML.memState)+    assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment)++    return mem{ memImplHeap = heap' }++-- | Allocate a memory region on the heap, with no source location info.+mallocRaw+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> MemImpl sym+  -> SymBV sym wptr {- ^ size in bytes -}+  -> Alignment+  -> IO (LLVMPtr sym wptr, MemImpl sym)+mallocRaw bak mem sz alignment =+  doMalloc bak G.HeapAlloc G.Mutable "<malloc>" mem sz alignment++-- | Allocate a read-only memory region on the heap, with no source location info.+mallocConstRaw+  :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => bak+  -> MemImpl sym+  -> SymBV sym wptr+  -> Alignment+  -> IO (LLVMPtr sym wptr, MemImpl sym)+mallocConstRaw bak mem sz alignment =+  doMalloc bak G.HeapAlloc G.Immutable "<malloc>" mem sz alignment++----------------------------------------------------------------------+-- Packing and unpacking+--++unpackZero ::+  (HasCallStack, IsSymInterface sym) =>+  sym ->+  StorageType ->+  TypeRepr tp {- ^ Crucible type     -} ->+  IO (RegValue sym tp)+unpackZero sym tp tpr =+ let mismatch = storageTypeMismatch "MemModel.unpackZero" tp tpr in+ case storageTypeF tp of+  Bitvector bytes ->+    zeroInt sym bytes $ \case+      Nothing -> fail ("Improper storable type: " ++ show tp)+      Just (blk, bv) ->+        case tpr of+          LLVMPointerRepr w | Just Refl <- testEquality (bvWidth bv) w -> return (LLVMPointer blk bv)+          _ -> mismatch++  Float  ->+    case tpr of+      FloatRepr SingleFloatRepr -> iFloatLitRational sym SingleFloatRepr 0+      _ -> mismatch++  Double ->+    case tpr of+      FloatRepr DoubleFloatRepr -> iFloatLitRational sym DoubleFloatRepr 0+      _ -> mismatch++  X86_FP80 ->+    case tpr of+      FloatRepr X86_80FloatRepr -> iFloatLitRational sym X86_80FloatRepr 0+      _ -> mismatch++  Array n tp' ->+    case tpr of+      VectorRepr tpr' ->+        do v <- unpackZero sym tp' tpr'+           return $ V.replicate (fromIntegral n) v+      _ -> mismatch++  Struct flds ->+    case tpr of+      StructRepr fldCtx | V.length flds == Ctx.sizeInt (Ctx.size fldCtx) ->+        Ctx.traverseWithIndex+          (\i tpr' -> RV <$> unpackZero sym (flds V.! (Ctx.indexVal i) ^. fieldVal) tpr')+          fldCtx++      _ -> mismatch+++storageTypeMismatch ::+  String ->+  StorageType ->+  TypeRepr tp ->+  IO a+storageTypeMismatch nm tp tpr =+  panic nm+  [ "Storage type mismatch in " ++ nm+  , "  Storage type: " ++ show tp+  , "  Crucible type: " ++ show tpr+  ]++-- | Unpack an 'LLVMVal' to produce a 'RegValue'.+unpackMemValue ::+  (HasCallStack, IsSymInterface sym) =>+  sym ->+  TypeRepr tp ->+  LLVMVal sym ->+  IO (RegValue sym tp)++unpackMemValue sym tpr (LLVMValZero tp)  = unpackZero sym tp tpr++unpackMemValue _sym (LLVMPointerRepr w) (LLVMValInt blk bv)+  | Just Refl <- testEquality (bvWidth bv) w+  = return $ LLVMPointer blk bv++unpackMemValue _ (FloatRepr SingleFloatRepr) (LLVMValFloat SingleSize x) = return x+unpackMemValue _ (FloatRepr DoubleFloatRepr) (LLVMValFloat DoubleSize x) = return x+unpackMemValue _ (FloatRepr X86_80FloatRepr) (LLVMValFloat X86_FP80Size x) = return x++unpackMemValue sym (StructRepr ctx) (LLVMValStruct xs)+  | V.length xs == Ctx.sizeInt (Ctx.size ctx)+  = Ctx.traverseWithIndex+       (\i tpr -> RV <$> unpackMemValue sym tpr (xs V.! Ctx.indexVal i ^. _2))+       ctx++unpackMemValue sym (VectorRepr tpr) (LLVMValArray _tp xs)+  = traverse (unpackMemValue sym tpr) xs++unpackMemValue _sym ctp@(BVRepr _) lval@(LLVMValInt _ _) =+    panic "MemModel.unpackMemValue"+      [ "Cannot unpack an integer LLVM value to a crucible bitvector type"+      , "*** Crucible type: " ++ show ctp+      , "*** LLVM value: " ++ show lval+      ]++unpackMemValue _ tpr v@(LLVMValUndef _) =+  panic "MemModel.unpackMemValue"+    [ "Cannot unpack an `undef` value"+    , "*** Crucible type: " ++ show tpr+    , "*** Undef value: " ++ show v+    ]++unpackMemValue _ tpr v =+  panic "MemModel.unpackMemValue"+    [ "Crucible type mismatch when unpacking LLVM value"+    , "*** Crucible type: " ++ show tpr+    , "*** LLVM value: " ++ show v+    ]+++-- | Pack a 'RegValue' into an 'LLVMVal'. The LLVM storage type and+-- the Crucible type must be compatible.+packMemValue ::+  IsSymInterface sym =>+  sym ->+  StorageType {- ^ LLVM storage type -} ->+  TypeRepr tp {- ^ Crucible type     -} ->+  RegValue sym tp ->+  IO (LLVMVal sym)++packMemValue _ (StorageType Float _) (FloatRepr SingleFloatRepr) x =+       return $ LLVMValFloat SingleSize x++packMemValue _ (StorageType Double _) (FloatRepr DoubleFloatRepr) x =+       return $ LLVMValFloat DoubleSize x++packMemValue _ (StorageType X86_FP80 _) (FloatRepr X86_80FloatRepr) x =+       return $ LLVMValFloat X86_FP80Size x++packMemValue sym (StorageType (Bitvector bytes) _) (BVRepr w) bv+  | bitsToBytes (natValue w) == bytes =+      do blk0 <- natLit sym 0+         return $ LLVMValInt blk0 bv++packMemValue _sym (StorageType (Bitvector bytes) _) (LLVMPointerRepr w) (LLVMPointer blk off)+  | bitsToBytes (natValue w) == bytes =+       return $ LLVMValInt blk off++packMemValue sym (StorageType (Array sz tp) _) (VectorRepr tpr) vec+  | V.length vec == fromIntegral sz = do+       vec' <- traverse (packMemValue sym tp tpr) vec+       return $ LLVMValArray tp vec'++packMemValue sym (StorageType (Struct fls) _) (StructRepr ctx) xs = do+  fls' <- V.generateM (V.length fls) $ \i -> do+              let fl = fls V.! i+              case Ctx.intIndex i (Ctx.size ctx) of+                Just (Some idx) -> do+                  let tpr = ctx Ctx.! idx+                  let RV val = xs Ctx.! idx+                  val' <- packMemValue sym (fl^.fieldVal) tpr val+                  return (fl, val')+                _ -> panic "MemModel.packMemValue"+                      [ "Mismatch between LLVM and Crucible types"+                      , "*** Filed out of bounds: " ++ show i+                      ]+  return $ LLVMValStruct fls'++packMemValue _ stTy crTy _ =+  panic "MemModel.packMemValue"+    [ "Type mismatch when storing value."+    , "*** Expected storable type: " ++ show stTy+    , "*** Given crucible type: " ++ show crTy+    ]+++----------------------------------------------------------------------+-- Disjointness+--++-- | Assert that two memory regions are disjoint.+-- Two memory regions are disjoint if any of the following are true:+--+--   1. Their block pointers are different+--   2. Their blocks are the same, but /dest+dlen/ <= /src/+--   3. Their blocks are the same, but /src+slen/ <= /dest/+assertDisjointRegions ::+  (1 <= w, HasPtrWidth wptr, IsSymBackend sym bak, Partial.HasLLVMAnn sym) =>+  bak ->+  MemoryOp sym wptr ->+  NatRepr w ->+  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->+  SymBV sym w      {- ^ length of region 1  -} ->+  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->+  SymBV sym w      {- ^ length of region 2  -} ->+  IO ()+assertDisjointRegions bak mop w dest dlen src slen = do+  let sym = backendGetSym bak+  c <- buildDisjointRegionsAssertion sym w dest dlen src slen+  c' <- Partial.annotateME sym mop OverlappingRegions c+  assert bak c' (AssertFailureSimError "Memory regions not disjoint" "")++buildDisjointRegionsAssertion ::+  (1 <= w, HasPtrWidth wptr, IsSymInterface sym) =>+  sym ->+  NatRepr w ->+  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->+  SymBV sym w      {- ^ length of region 1  -} ->+  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->+  SymBV sym w      {- ^ length of region 2  -} ->+  IO (Pred sym)+buildDisjointRegionsAssertion sym w dest dlen src slen = do+  let LLVMPointer dblk doff = dest+  let LLVMPointer sblk soff = src++  dend <- bvAdd sym doff =<< sextendBVTo sym w PtrWidth dlen+  send <- bvAdd sym soff =<< sextendBVTo sym w PtrWidth slen++  diffBlk   <- notPred sym =<< natEq sym dblk sblk+  destfirst <- bvSle sym dend soff+  srcfirst  <- bvSle sym send doff++  orPred sym diffBlk =<< orPred sym destfirst srcfirst++-- | Build the condition that two memory regions are disjoint, using+-- subtraction and comparison to zero instead of direct comparison (that is,+-- 0 <= y - x instead of x <= y). This enables semiring and abstract domain+-- simplifications. The result if false if any offset is not positive when+-- interpreted as signed bitvector.+buildDisjointRegionsAssertionWithSub ::+  (HasPtrWidth wptr, IsSymInterface sym) =>+  sym ->+  LLVMPtr sym wptr {- ^ pointer to region 1 -} ->+  SymBV sym wptr   {- ^ length of region 1  -} ->+  LLVMPtr sym wptr {- ^ pointer to region 2 -} ->+  SymBV sym wptr   {- ^ length of region 2  -} ->+  IO (Pred sym)+buildDisjointRegionsAssertionWithSub sym dest dlen src slen = do+  let LLVMPointer dblk doff = dest+  let LLVMPointer sblk soff = src++  dend <- bvAdd sym doff dlen+  send <- bvAdd sym soff slen++  zero_bv <- bvLit sym PtrWidth $ BV.zero PtrWidth++  diffBlk <- notPred sym =<< natEq sym dblk sblk++  allPos <- andAllOf sym folded =<< mapM (bvSle sym zero_bv) [doff, dend, soff, send]+  destfirst <- bvSle sym zero_bv =<< bvSub sym soff dend+  srcfirst <- bvSle sym zero_bv =<< bvSub sym doff send++  orPred sym diffBlk =<< andPred sym allPos =<< orPred sym destfirst srcfirst++----------------------------------------------------------------------+-- constToLLVMVal+--++-- | This is used (by saw-script) to initialize globals.+--+-- In this translation, we lose the distinction between pointers and ints.+--+-- This is parameterized (hence, \"P\") over a function for looking up the+-- pointer values of global symbols. This parameter is used by @populateGlobal@+-- to recursively populate globals that may reference one another.+constToLLVMValP :: forall wptr sym io.+  ( MonadIO io+  , MonadFail io+  , HasPtrWidth wptr+  , IsSymInterface sym+  , HasCallStack+  ) => sym                                 -- ^ The symbolic backend+    -> (L.Symbol -> io (LLVMPtr sym wptr)) -- ^ How to look up global symbols+    -> LLVMConst                           -- ^ Constant expression to translate+    -> io (LLVMVal sym)++-- See comment on @LLVMVal@ on why we use a literal 0.+constToLLVMValP sym _ (IntConst w i) = liftIO $+  LLVMValInt <$> natLit sym 0 <*> bvLit sym w i++constToLLVMValP sym _ (FloatConst f) = liftIO $+  LLVMValFloat SingleSize <$> iFloatLitSingle sym f++constToLLVMValP sym _ (DoubleConst d) = liftIO $+  LLVMValFloat DoubleSize <$> iFloatLitDouble sym d++constToLLVMValP sym _ (LongDoubleConst (L.FP80_LongDouble e s)) = liftIO $+  LLVMValFloat X86_FP80Size <$> iFloatLitLongDouble sym (X86_80Val e s)++constToLLVMValP _ _ (StringConst bs) =+  pure (LLVMValString bs)++constToLLVMValP sym look (ArrayConst memty xs) =+  LLVMValArray <$> liftIO (toStorableType memty)+               <*> (V.fromList <$> traverse (constToLLVMValP sym look) xs)++-- Same as the array case+constToLLVMValP sym look (VectorConst memty xs) =+  LLVMValArray <$> liftIO (toStorableType memty)+               <*> (V.fromList <$> traverse (constToLLVMValP sym look) xs)++constToLLVMValP sym look (StructConst sInfo xs) =+  LLVMValStruct <$>+    V.zipWithM (\x y -> (,) <$> liftIO (fiToFT x) <*> constToLLVMValP sym look y)+               (siFields sInfo)+               (V.fromList xs)++-- SymbolConsts are offsets from global pointers. We translate them into the+-- pointer they represent.+constToLLVMValP sym look (SymbolConst symb i) = do+  -- Pointer to the global "symb"+  ptr <- look symb+  -- Offset to be added, as a bitvector+  ibv <- liftIO $ bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth i)++  -- blk is the allocation number that this global is stored in.+  -- In contrast to the case for @IntConst@ above, it is non-zero.+  let (blk, offset) = llvmPointerView ptr+  LLVMValInt blk <$> liftIO (bvAdd sym offset ibv)++constToLLVMValP _sym _look (ZeroConst memty) = liftIO $+  LLVMValZero <$> toStorableType memty+constToLLVMValP _sym _look (UndefConst memty) = liftIO $+  LLVMValUndef <$> toStorableType memty+++-- | Translate a constant into an LLVM runtime value. Assumes all necessary+-- globals have already been populated into the @'MemImpl'@.+constToLLVMVal :: forall wptr sym bak io.+  ( MonadIO io+  , MonadFail io+  , HasPtrWidth wptr+  , IsSymBackend sym bak+  , HasCallStack+  ) => bak               -- ^ The symbolic backend+    -> MemImpl sym       -- ^ The current memory state, for looking up globals+    -> LLVMConst         -- ^ Constant expression to translate+    -> io (LLVMVal sym)  -- ^ Runtime representation of the constant expression++-- See comment on @LLVMVal@ on why we use a literal 0.+constToLLVMVal bak mem =+  constToLLVMValP (backendGetSym bak)+     (\symb -> liftIO $ doResolveGlobal bak mem symb)++-- TODO are these types just identical? Maybe we should combine them.+fiToFT :: (HasPtrWidth wptr, MonadFail m) => FieldInfo -> m (Field StorageType)+fiToFT fi = fmap (\t -> mkField (fiOffset fi) t (fiPadding fi))+                 (toStorableType $ fiType fi)++----------------------------------------------------------------------+-- Globals+--++-- | Look up a 'Symbol' in the global map of the given 'MemImpl'.+-- Panic if the symbol is not present in the global map.+doResolveGlobal ::+  (IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) =>+  bak ->+  MemImpl sym ->+  L.Symbol {- ^ name of global -} ->+  IO (LLVMPtr sym wptr)+doResolveGlobal bak mem symbol@(L.Symbol name) =+  let lookedUp = Map.lookup symbol (memImplGlobalMap mem)+      msg1 = "Global allocation has incorrect width"+      msg1Details = mconcat [ "Allocation associated with global symbol \""+                            , name+                            , "\" is not a pointer of the correct width"+                            ]+      msg2 = "Global symbol not allocated"+      msg2Details = mconcat [ "Global symbol \""+                            , name+                            , "\" has no associated allocation"+                            ]+  in case lookedUp of+       Just (SomePointer ptr) | PtrWidth <- ptrWidth ptr -> return ptr+       _ -> addFailedAssertion bak $+         if isJust lookedUp+         then AssertFailureSimError msg1 msg1Details+         else AssertFailureSimError msg2 msg2Details++-- | Add an entry to the global map of the given 'MemImpl'.+--+-- This takes a list of symbols because there may be aliases to a global.+registerGlobal ::+  (IsExprBuilder sym, 1 <= wptr) =>+  MemImpl sym -> [L.Symbol] -> LLVMPtr sym wptr -> MemImpl sym+registerGlobal (MemImpl blockSource gMap sMap hMap mem) symbols ptr =+  MemImpl blockSource gMap' sMap' hMap mem+  where+    gMap' = foldr (\s m -> Map.insert s (SomePointer ptr) m) gMap symbols+    sMap' =+      fromMaybe sMap $+      do symbol <- listToMaybe symbols+         n <- asNat (llvmPointerBlock ptr)+         z <- asBV (llvmPointerOffset ptr)+         guard (BV.asUnsigned z == 0)+         Just (Map.insert n symbol sMap)++-- | Allocate memory for each global, and register all the resulting+-- pointers in the global map.+allocGlobals ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  [(L.Global, [L.Symbol], Bytes, Alignment)] ->+  MemImpl sym ->+  IO (MemImpl sym)+allocGlobals bak gs mem = foldM (allocGlobal bak) mem gs++allocGlobal ::+  ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  bak ->+  MemImpl sym ->+  (L.Global, [L.Symbol], Bytes, Alignment) ->+  IO (MemImpl sym)+allocGlobal bak mem (g, aliases, sz, alignment) = do+  let sym = backendGetSym bak+  let symbol@(L.Symbol sym_str) = L.globalSym g+  let displayName = "[global variable  ] " ++ sym_str+  let mut = if L.gaConstant (L.globalAttrs g) then G.Immutable else G.Mutable+  sz' <- bvLit sym PtrWidth (bytesToBV PtrWidth sz)+  -- TODO: Aliases are not propagated to doMalloc for error messages+  (ptr, mem') <- doMalloc bak G.GlobalAlloc mut displayName mem sz' alignment+  return (registerGlobal mem' (symbol:aliases) ptr)+++concSomePointer ::+  IsSymInterface sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  SomePointer sym -> IO (SomePointer sym)+concSomePointer sym conc (SomePointer ptr) =+  SomePointer <$> ML.concPtr sym conc ptr++concMemImpl ::+  IsSymInterface sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemImpl sym -> IO (MemImpl sym)+concMemImpl sym conc mem =+  do heap' <- ML.concMem sym conc (memImplHeap mem)+     gm'   <- traverse (concSomePointer sym conc) (memImplGlobalMap mem)+     pure mem{ memImplHeap = heap', memImplGlobalMap = gm' }
+ src/Lang/Crucible/LLVM/MemModel/CallStack.hs view
@@ -0,0 +1,19 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.CallStack+-- Description      : Call stacks from the LLVM memory model+-- Copyright        : (c) Galois, Inc 2024+-- License          : BSD3+-- Maintainer       : Langston Barrett <langston@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++module Lang.Crucible.LLVM.MemModel.CallStack+  ( CallStack+  , null+  , getCallStack+  , ppCallStack+  ) where++import Prelude hiding (null)+import Lang.Crucible.LLVM.MemModel.CallStack.Internal
+ src/Lang/Crucible/LLVM/MemModel/CallStack/Internal.hs view
@@ -0,0 +1,53 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.CallStack.Internal+-- Description      : Call stacks from the LLVM memory model (implementation details)+-- Copyright        : (c) Galois, Inc 2024+-- License          : BSD3+-- Maintainer       : Langston Barrett <langston@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Lang.Crucible.LLVM.MemModel.CallStack.Internal where++import           Data.Foldable (toList)+import           Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import           Data.Text (Text)+import qualified Prettyprinter as PP++import           Lang.Crucible.LLVM.MemModel.MemLog (MemState(..))++newtype FunctionName =+  FunctionName { getFunctionName :: Text }+  deriving (Eq, Monoid, Ord, Semigroup)++-- | Call stacks (lists of function names), mostly for diagnostics+newtype CallStack =+  CallStack { runCallStack :: Seq FunctionName }+  deriving (Eq, Monoid, Ord, Semigroup)++-- | Add a function name to the top of the call stack+cons :: FunctionName -> CallStack -> CallStack+cons top (CallStack rest) = CallStack (top Seq.<| rest)++-- | Is this 'CallStack' empty?+null :: CallStack -> Bool+null = Seq.null . runCallStack++-- | Summarize the 'StackFrame's of a 'MemState' into a 'CallStack'+getCallStack :: MemState sym -> CallStack+getCallStack =+  \case+    EmptyMem{} -> CallStack mempty+    StackFrame _ _ nm _ rest -> cons (FunctionName nm) (getCallStack rest)+    BranchFrame _ _ _ rest -> getCallStack rest++-- | Pretty-print a call stack (one function per line)+ppCallStack :: CallStack -> PP.Doc ann+ppCallStack =+  PP.vsep . toList . fmap (PP.pretty . getFunctionName) . runCallStack
+ src/Lang/Crucible/LLVM/MemModel/Common.hs view
@@ -0,0 +1,713 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Common+-- Description      : Core definitions of the symbolic C memory model+-- Copyright        : (c) Galois, Inc 2011-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Lang.Crucible.LLVM.MemModel.Common+  ( -- * Range declarations.+    Range(..)++    -- * Pointer declarations+  , OffsetExpr(..)+  , IntExpr(..)+  , Cond(..)++  , Mux(..)++  , ValueCtor(..)++  , BasePreference(..)++  , RangeLoad(..)+  , rangeLoad+  , fixedOffsetRangeLoad+  , fixedSizeRangeLoad+  , symbolicRangeLoad+  , symbolicUnboundedRangeLoad++  , ValueView(..)++  , ValueLoad(..)+  , valueLoad+  , LinearLoadStoreOffsetDiff(..)+  , symbolicValueLoad+  , loadBitvector++  , memsetValue+  , loadTypedValueFromBytes+  ) where++import Control.Exception (assert)+import Control.Lens+import Control.Monad (guard)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Vector (Vector)+import qualified Data.Vector as V+import Numeric.Natural++import Lang.Crucible.Panic ( panic )+import Lang.Crucible.LLVM.Bytes+import Lang.Crucible.LLVM.MemModel.Type++-- | @R i j@ denotes that the write should store in range [i..j).+data Range = R { rStart :: Addr, _rEnd :: Addr }+  deriving (Eq, Show)++-- Value++data OffsetExpr+  = OffsetAdd OffsetExpr IntExpr+  | Load+  | Store+  deriving (Show)++data IntExpr+  = OffsetDiff OffsetExpr OffsetExpr+  | IntAdd IntExpr IntExpr+  | CValue Bytes+  | StoreSize+  deriving (Show)++data Cond+  = OffsetEq OffsetExpr OffsetExpr+  | OffsetLe OffsetExpr OffsetExpr+  | IntEq IntExpr IntExpr+  | IntLe IntExpr IntExpr+  | And Cond Cond+  | Or Cond Cond+  deriving (Show)++(.==) :: OffsetExpr -> OffsetExpr -> Cond+infix 4 .==+x .== y = OffsetEq x y++(.<=) :: OffsetExpr -> OffsetExpr -> Cond+infix 4 .<=+x .<= y = OffsetLe x y++infixl 6 .++(.+) :: OffsetExpr -> IntExpr -> OffsetExpr+x .+ CValue 0 = x+x .+ y = OffsetAdd x y++infixl 6 .-+(.-) :: OffsetExpr -> OffsetExpr -> IntExpr+x .- y = OffsetDiff x y++-- Muxs++data Mux a+  = Mux Cond (Mux a) (Mux a)+  | MuxTable OffsetExpr OffsetExpr (Map Bytes (Mux a)) (Mux a)+    -- ^ 'MuxTable' encodes a lookup table: @'MuxTable' p1 p2+    -- 'Map.empty' z@ is equivalent to @z@, and @'MuxTable' p1 p2+    -- ('Map.insert' (i, x) m) z@ is equivalent to @'Mux' (p1 '.+'+    -- 'CValue' i '.==' p2) x ('MuxTable' p1 p2 m z)@.+  | MuxVar a+  deriving Show++-- Variable for mem model.++loadOffset :: Bytes -> OffsetExpr+loadOffset n = Load .+ CValue n++storeOffset :: Bytes -> OffsetExpr+storeOffset n = Store .+ CValue n++storeEnd :: OffsetExpr+storeEnd = Store .+ StoreSize++-- | @loadInStoreRange n@ returns predicate if Store <= Load && Load <= Store + n+loadInStoreRange :: Bytes -> Cond+loadInStoreRange (Bytes 0) = Load .== Store+loadInStoreRange n = And (Store .<= Load)+                         (Load .<= Store .+ CValue n)++-- Value constructor++-- | Describes how to construct a larger LLVM value as a combination+-- of smaller components.+data ValueCtor a+  = ValueCtorVar a+    -- | Concatenates two bitvectors.+    -- The first bitvector contains values stored at the low-address bytes+    -- while the second contains values at the high-address bytes. Thus, the+    -- meaning of this depends on the endianness of the target architecture.+  | ConcatBV (ValueCtor a) (ValueCtor a)+  | BVToFloat (ValueCtor a)+  | BVToDouble (ValueCtor a)+  | BVToX86_FP80 (ValueCtor a)+    -- | Cons one value to beginning of array.+  | ConsArray (ValueCtor a) (ValueCtor a)+  | AppendArray (ValueCtor a) (ValueCtor a)+  | MkArray StorageType (Vector (ValueCtor a))+  | MkStruct (Vector (Field StorageType, ValueCtor a))+  deriving (Functor, Foldable, Traversable, Show)++concatBV :: Bytes -> ValueCtor a -> Bytes -> ValueCtor a -> ValueCtor a+concatBV _xw x _yw y = ConcatBV x y++singletonArray :: StorageType -> ValueCtor a -> ValueCtor a+singletonArray tp e = MkArray tp (V.singleton e)++-- | Create value of type that splits at a particular byte offset.+splitTypeValue :: StorageType   -- ^ Type of value to create+               -> Offset -- ^ Bytes offset to slice type at.+               -> (Offset -> StorageType -> ValueCtor a) -- ^ Function for subtypes.+               -> ValueCtor a+splitTypeValue tp d subFn = assert (d > 0) $+  case storageTypeF tp of+    Bitvector sz -> assert (d < sz) $+      concatBV d (subFn 0 (bitvectorType d))+               (sz - d) (subFn d (bitvectorType (sz - d)))+    Float -> BVToFloat (subFn 0 (bitvectorType 4))+    Double -> BVToDouble (subFn 0 (bitvectorType 8))+    X86_FP80 -> BVToX86_FP80 (subFn 0 (bitvectorType 10))+    Array n0 etp -> assert (n0 > 0) $ do+      let esz = storageTypeSize etp+      let (c,part) = assert (esz > 0) $ toInteger d `divMod` toInteger esz+      let n = toInteger n0 - toInteger c+      let o = d - toBytes part -- (Bytes c) * esz+      let consPartial+            | n < 0 = panic "splitTypeValue" ["Unexpected array size: " ++ show n, show tp, show d]+            | part == 0 = subFn o (arrayType (fromInteger n) etp)+            | n > 1 =+                ConsArray (subFn o etp)+                          (subFn (o+esz) (arrayType (fromInteger (n-1)) etp))+            | otherwise = assert (n == 1) $+                singletonArray etp (subFn o etp)+      let result+            | c > 0 = assert (c < toInteger n0) $+              AppendArray (subFn 0 (arrayType (fromInteger c) etp))+                          consPartial+            | otherwise = consPartial+      result+    Struct flds -> MkStruct (fldFn <$> flds)+      where fldFn fld = (fld, subFn (fieldOffset fld) (fld^.fieldVal))++-- | This is used so that when we are comparing symbolic loads against+-- previous stores, we can represent the difference as relative to+-- a fixed address whenever possible.+data BasePreference+   = FixedLoad+   | FixedStore+   | NeitherFixed+  deriving (Eq, Show)++-- RangeLoad++-- | A 'RangeLoad' describes different kinds of memory loads in the+-- context of a byte range copied into an old memory.+data RangeLoad a b+  = OutOfRange a StorageType+    -- ^ Load from an address range disjoint from the copied bytes.+    -- The arguments represent the address and type of the load.+  | InRange b StorageType+    -- ^ Load consists of bytes within the copied range. The first+    -- argument represents the offset relative to the start of the+    -- copied bytes.+  deriving (Show)++adjustOffset :: (b -> d)+             -> (a -> c)+             -> RangeLoad a b -> RangeLoad c d+adjustOffset _ outFn (OutOfRange a tp) = OutOfRange (outFn a) tp+adjustOffset inFn _  (InRange b tp) = InRange (inFn b) tp++-- | Decomposes a single load after a memcopy into a combination of+-- simple value loads.+rangeLoad ::+  Addr  {- ^ load offset  -} ->+  StorageType {- ^ load type    -} ->+  Range {- ^ copied range -} ->+  ValueCtor (RangeLoad Addr Addr)+rangeLoad lo ltp s@(R so se)+   | so == se  = loadFail+   | le <= so  = loadFail+   | se <= lo  = loadFail+   | lo < so   = splitTypeValue ltp (so - lo) (\o tp -> rangeLoad (lo+o) tp s)+   | se < le   = splitTypeValue ltp (se - lo) (\o tp -> rangeLoad (lo+o) tp s)+   | otherwise = assert (so <= lo && le <= se) $ ValueCtorVar (InRange (lo - so) ltp)+ where le = typeEnd lo ltp+       loadFail = ValueCtorVar (OutOfRange lo ltp)++-- | Produces a @Mux ValueCtor@ expression representing the range load conditions+-- when the load and store offsets are concrete and the store size is bounded+fixedOffsetRangeLoad :: Addr+                     -- ^ Address of load+                     -> StorageType+                     -- ^ Type to load+                     -> Addr+                     -- ^ Address of store+                     -> Mux (ValueCtor (RangeLoad Addr Addr))+fixedOffsetRangeLoad l tp s+  | s < l = do -- Store is before load.+    let sd = l - s -- Number of bytes load comes after store+    Mux (IntLe StoreSize (CValue sd)) loadFail (loadCase (sd+1))+  | le <= s = loadFail -- No load if load ends before write.+  | otherwise = loadCase 0+  where+    le = typeEnd l tp+    loadCase i+      | i < le-s  = Mux (IntEq StoreSize (CValue i)) (loadVal i) (loadCase (i+1))+      | otherwise = loadVal i+    loadVal ssz = MuxVar (rangeLoad l tp (R s (s+ssz)))+    loadFail = MuxVar (ValueCtorVar (OutOfRange l tp))++-- | @fixLoadBeforeStoreOffset pref i k@ adjusts a pointer value that is relative+-- the load address into a global pointer.  The code assumes that @load + i == store@.+fixLoadBeforeStoreOffset :: BasePreference -> Offset -> Offset -> OffsetExpr+fixLoadBeforeStoreOffset pref i k+  | pref == FixedStore = Store .+ CValue (k - i)+  | otherwise = Load .+ CValue k++-- | @fixLoadAfterStoreOffset pref i k@ adjusts a pointer value that is relative+-- the load address into a global pointer.  The code assumes that @load == store + i@.+fixLoadAfterStoreOffset :: BasePreference -> Offset -> Offset -> OffsetExpr+fixLoadAfterStoreOffset pref i k = assert (k >= i) $+  case pref of+    FixedStore -> Store .+ CValue k+    _          -> Load  .+ CValue (k - i)++-- | @loadFromStoreStart pref tp i j@ loads a value of type @tp@ from a range under the+-- assumptions that @load + i == store@ and @j = i + min(StoreSize, typeEnd(tp)@.+loadFromStoreStart :: BasePreference+                   -> StorageType+                   -> Offset+                   -> Offset+                   -> ValueCtor (RangeLoad OffsetExpr IntExpr)+loadFromStoreStart pref tp i j = adjustOffset inFn outFn <$> rangeLoad 0 tp (R i j)+  where inFn = CValue+        outFn = fixLoadBeforeStoreOffset pref i++-- | Produces a @Mux ValueCtor@ expression representing the range load conditions+-- when the load and store values are concrete+fixedSizeRangeLoad :: BasePreference -- ^ Whether addresses are based on store or load.+                   -> StorageType+                   -> Bytes+                   -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))+fixedSizeRangeLoad _ tp 0 = MuxVar (ValueCtorVar (OutOfRange Load tp))+fixedSizeRangeLoad pref tp ssz =+  Mux (loadOffset lsz .<= Store) loadFail (prefixL lsz)+  where+    lsz = typeEnd 0 tp++    prefixL i+      | i > 0 = Mux (loadOffset i .== Store) (loadVal i) (prefixL (i-1))+      -- Special case where we skip some offsets, it it won't+      -- make more splitting+      | lsz <= ssz && pref == NeitherFixed =+        -- Load is contained in storage.+        Mux (loadInStoreRange (ssz-lsz)) loadSucc $+        -- Load extends past end of storage+        suffixS (ssz-lsz)+      | otherwise = suffixS 0++    suffixS i+      | i < ssz   = Mux (Load .== storeOffset i) (storeVal i) (suffixS (i+1))+      | otherwise = loadFail++    loadVal i = MuxVar (loadFromStoreStart pref tp i (i+ssz))++    storeVal i = MuxVar (adjustOffset inFn outFn <$> rangeLoad i tp (R 0 ssz))+      where inFn = CValue+            outFn = fixLoadAfterStoreOffset pref i++    loadSucc = MuxVar (ValueCtorVar (InRange (Load .- Store) tp))+    loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp))++-- | Produces a @Mux ValueCtor@ expression representing the range load conditions+-- when the load and store values are symbolic and the @StoreSize@ is bounded.+symbolicRangeLoad :: BasePreference -> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))+symbolicRangeLoad pref tp =+  Mux (Store .<= Load)+  (Mux (loadOffset sz .<= storeEnd) (loadVal0 sz) (loadIter0 (sz-1)))+  (storeAfterLoad 1)+  where+    sz = typeEnd 0 tp++    loadIter0 j+      | j > 0     = Mux (loadOffset j .== storeEnd) (loadVal0 j) (loadIter0 (j-1))+      | otherwise = loadFail++    loadVal0 j = MuxVar $ adjustOffset inFn outFn <$> rangeLoad 0 tp (R 0 j)+      where inFn k  = IntAdd (OffsetDiff Load Store) (CValue k)+            outFn k = OffsetAdd Load (CValue k)++    storeAfterLoad i+      | i < sz = Mux (loadOffset i .== Store) (loadFromOffset i) (storeAfterLoad (i+1))+      | otherwise = loadFail++    loadFromOffset i =+      assert (0 < i && i < sz) $+      Mux (IntLe (CValue (sz - i)) StoreSize) (loadVal i (i+sz)) (f (sz-1))+      where f j | j > i = Mux (IntEq (CValue (j-i)) StoreSize) (loadVal i j) (f (j-1))+                | otherwise = loadFail++    loadVal i j = MuxVar (loadFromStoreStart pref tp i j)+    loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp))++-- | Produces a @Mux ValueCtor@ expression representing the RangeLoad conditions+-- when the load and store values are symbolic and the @StoreSize@ is unbounded.+symbolicUnboundedRangeLoad :: BasePreference -> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr))+symbolicUnboundedRangeLoad pref tp =+  Mux (Store .<= Load)+  (loadVal0 sz)+  (storeAfterLoad 1)+  where+    sz = typeEnd 0 tp++    loadVal0 j = MuxVar $ adjustOffset inFn outFn <$> rangeLoad 0 tp (R 0 j)+      where inFn k  = IntAdd (OffsetDiff Load Store) (CValue k)+            outFn k = OffsetAdd Load (CValue k)++    storeAfterLoad i+      | i < sz = Mux (loadOffset i .== Store) (loadFromOffset i) (storeAfterLoad (i+1))+      | otherwise = loadFail++    loadFromOffset i =+      assert (0 < i && i < sz) $+      Mux (IntLe (CValue (sz - i)) StoreSize) (loadVal i (i+sz)) (f (sz-1))+      where f j | j > i = Mux (IntEq (CValue (j-i)) StoreSize) (loadVal i j) (f (j-1))+                | otherwise = loadFail++    loadVal i j = MuxVar (loadFromStoreStart pref tp i j)+    loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp))++-- ValueView++-- | Represents a projection of a sub-component out of a larger LLVM value.+data ValueView+  = ValueViewVar StorageType+    -- | Select low-address bytes in the bitvector.+    -- The sizes include the number of low bytes, and the number of high bytes.+  | SelectPrefixBV Bytes Bytes ValueView+    -- | Select the given number of high-address bytes in the bitvector.+    -- The sizes include the number of low bytes, and the number of high bytes.+  | SelectSuffixBV Bytes Bytes ValueView+  | FloatToBV ValueView+  | DoubleToBV ValueView+  | X86_FP80ToBV ValueView+  | ArrayElt Natural StorageType Natural ValueView++  | FieldVal (Vector (Field StorageType)) Int ValueView+  deriving (Show, Eq, Ord)++viewType :: ValueView -> Maybe StorageType+viewType (ValueViewVar tp) = Just tp+viewType (SelectPrefixBV u v vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (Bitvector (u + v) == tp)+     pure $ bitvectorType u+viewType (SelectSuffixBV u v vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (Bitvector (u + v) == tp)+     pure $ bitvectorType v+viewType (FloatToBV vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (Float == tp)+     pure $ bitvectorType 4+viewType (DoubleToBV vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (Double == tp)+     pure $ bitvectorType 8+viewType (X86_FP80ToBV vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (X86_FP80 == tp)+     pure $ bitvectorType 10+viewType (ArrayElt n etp i vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (i < n && Array n etp == tp)+     pure $ etp+viewType (FieldVal v i vv) =+  do tp <- storageTypeF <$> viewType vv+     guard (Struct v == tp)+     view fieldVal <$> (v V.!? i)++-- | A 'ValueLoad' describes different kinds of memory loads in the+-- context of a new value stored into an old memory.+data ValueLoad v+  = OldMemory v StorageType+    -- ^ Load from an address range disjoint from the stored value.+    -- The arguments represent the address and type of the load.+  | LastStore ValueView+    -- ^ Load consists of valid bytes within the stored value.+  | InvalidMemory StorageType+    -- ^ Load touches invalid memory. Currently, this can only arise when+    -- trying to read struct padding bytes as a bitvector.+  deriving (Functor,Show)++loadBitvector :: Addr -> Bytes -> Addr -> ValueView -> ValueCtor (ValueLoad Addr)+loadBitvector lo lw so v = do+  let le = lo + lw+  let ltp = bitvectorType lw+  let stp = fromMaybe (error ("loadBitvector given bad view " ++ show v)) (viewType v)+  let retValue eo v' = (sz', valueLoad lo' (bitvectorType sz') eo v')+        where etp = fromMaybe (error ("Bad view " ++ show v')) (viewType v')+              esz = storageTypeSize etp+              lo' = max lo eo+              sz' = min le (eo+esz) - lo'+  case storageTypeF stp of+    Bitvector sw+      | so < lo -> do+        -- Number of bytes to drop.+        let d = lo - so+        -- Store is before load.+        valueLoad lo ltp lo (SelectSuffixBV d (sw - d) v)+      | otherwise -> assert (lo == so && lw < sw) $+        -- Load ends before store ends.+        valueLoad lo ltp so (SelectPrefixBV lw (sw - lw) v)+    Float -> valueLoad lo ltp so (FloatToBV v)+    Double -> valueLoad lo ltp so (DoubleToBV v)+    X86_FP80 -> valueLoad lo ltp so (X86_FP80ToBV v)+    Array n tp -> snd $ foldl1 cv (val <$> r)+      where cv (wx,x) (wy,y) = (wx + wy, concatBV wx x wy y)+            esz = storageTypeSize tp+            c0 = assert (esz > 0) $ toInteger (lo - so) `div` toInteger esz+            (c1, p1) = toInteger (le - so) `divMod` toInteger esz+            -- Get range of indices to read.+            r | p1 == 0 = assert (c1 > c0) [c0..c1-1]+              | otherwise = assert (c1 >= c0) [c0..c1]+            val i+              | i >= 0 = retValue (so + natBytesMul (fromInteger i) esz) (ArrayElt n tp (fromInteger i) v)+              | otherwise = panic "loadBitvector" ["Bad array index", show i, show (lo, lw, so, v)]+    Struct sflds -> assert (not (null r)) $ snd $ foldl1 cv r+      where cv (wx,x) (wy,y) = (wx+wy, concatBV wx x wy y)+            r = concat (zipWith val [0..] (V.toList sflds))+            val i f = v1+              where eo = so + fieldOffset f+                    ee = eo + storageTypeSize (f^.fieldVal)+                    v1 | le <= eo = v2+                       | ee <= lo = v2+                       | otherwise = retValue eo (FieldVal sflds i v) : v2+                    v2 | fieldPad f == 0 = []   -- Return no padding.+                       | le <= ee = [] -- Nothing of load ends before padding.+                         -- Nothing if padding ends before load begins.+                       | ee+fieldPad f <= lo = []+                       | otherwise = [(p, ValueCtorVar badMem)]+                      where p = min (ee+fieldPad f) le - (max lo ee)+                            tpPad  = bitvectorType p+                            badMem = InvalidMemory tpPad++-- | Decomposes a single load after a store into a combination of+-- simple value loads.+valueLoad ::+  Addr      {- ^ load address         -} ->+  StorageType      {- ^ load type            -} ->+  Addr      {- ^ store address        -} ->+  ValueView {- ^ view of stored value -} ->+  ValueCtor (ValueLoad Addr)+valueLoad lo ltp so v+  | le <= so = ValueCtorVar (OldMemory lo ltp) -- Load ends before store+  | se <= lo = ValueCtorVar (OldMemory lo ltp) -- Store ends before load+    -- Load is before store.+  | lo < so  = splitTypeValue ltp (so - lo) (\o tp -> valueLoad (lo+o) tp so v)+    -- Load ends after store ends.+  | se < le  = splitTypeValue ltp (le - se) (\o tp -> valueLoad (lo+o) tp so v)+  | (lo,ltp) == (so,stp) = ValueCtorVar (LastStore v)+  | otherwise =+    case storageTypeF ltp of+      Bitvector lw -> loadBitvector lo lw so v+      Float  -> BVToFloat  $ valueLoad lo (bitvectorType 4) so v+      Double -> BVToDouble $ valueLoad lo (bitvectorType 8) so v+      X86_FP80 -> BVToX86_FP80 $ valueLoad lo (bitvectorType 10) so v+      Array ln tp ->+        let leSize = storageTypeSize tp+            val i = valueLoad (lo+leSize*fromIntegral i) tp so v+         in MkArray tp (V.generate (fromIntegral ln) val)+      Struct lflds ->+        let val f = (f, valueLoad (lo+fieldOffset f) (f^.fieldVal) so v)+         in MkStruct (val <$> lflds)+ where stp = fromMaybe (error ("Coerce value given bad view " ++ show v)) (viewType v)+       le = typeEnd lo ltp+       se = so + storageTypeSize stp++-- | @LinearLoadStoreOffsetDiff stride delta@ represents the fact that+--   the difference between the load offset and the store offset is+--   of the form @stride * n + delta@ for some integer @n@, where+--   @stride@ and @delta@ are non-negative integers, and @n@ can be+--   positive, negative, or zero.  If no form if known, then @stride@ is @1@+--   and @delta@ is @0@.+data LinearLoadStoreOffsetDiff = LinearLoadStoreOffsetDiff Bytes Bytes++-- | This function computes a mux tree value for loading a chunk from inside+--   a previously-written value.  The @StorageType@ of the load indicates+--   the size of the loaded value and how we intend to view it.  The bounds,+--   if provided, are bounds on the difference between the load pointer and the+--   store pointer.  Postive values indicate the Load offset is larger than the+--   store offset.  These bounds, if provided, are used to shrink the size of+--   the computed mux tree, and can lead to significantly smaller results.+--   The @ValueView@ is the syntactic representation of the value being+--   loaded from.  The @LinearLoadStoreOffsetDiff@ form further reduces the size+--   of the mux tree by only considering (load offset - store offset) values of+--   the given form.+symbolicValueLoad ::+  BasePreference {- ^ whether addresses are based on store or load -} ->+  StorageType           {- ^ load type            -} ->+  Maybe (Integer, Integer) {- ^ optional bounds on the offset between load and store -} ->+  ValueView      {- ^ view of stored value -} ->+  LinearLoadStoreOffsetDiff {- ^ linear (load offset - store offset) form -} ->+  Mux (ValueCtor (ValueLoad OffsetExpr))+symbolicValueLoad pref tp bnd v (LinearLoadStoreOffsetDiff stride delta) =+  Mux (Or (loadOffset lsz .<= Store) (storeOffset (storageTypeSize stp) .<= Load)) loadFail $+  MuxTable Load Store prefixTable $+  MuxTable Store Load suffixTable loadFail+  where+    lsz = typeEnd 0 tp+    stp = case viewType v of+            Just x -> x+            Nothing -> panic "crucible-llvm:symbolicValueLoad"+                       [ "Unable obtain type of stored value ValueView" ]++    -- The prefix table represents cases where the load pointer occurs strictly before the+    -- write pointer, so that the end of the load may be partially satisfied by this write.+    prefixTable = mkPrefixTable prefixLoBound++    -- The suffix table represents cases where the load pointer occurs at or after the write+    -- pointer so that the load is fully satisfied or the beginning is partially satisfied+    -- by this write.+    suffixTable = mkSuffixTable suffixLoBound++    -- The smallest (non-negative) offset value that can occur in the suffix table.+    -- This is either 0 (load = store) or is given by the difference bound when+    -- the low value is positive.+    suffixLoBound =+      case bnd of+        Just (lo, _hi)+          | lo > 0 -> adjustLoBound delta (toBytes lo)+        _ -> delta++    -- One past the largest offset value that can occur in the suffix table.+    -- This is either the length of the written value, or is given by the+    -- difference bound.  Note, in the case @hi@ is negative, the suffix table+    -- will be empty.+    suffixHiBound =+      case bnd of+        Just (_lo, hi)+          | hi >= 0   -> min (storageTypeSize stp) (toBytes hi + 1)+          | otherwise -> 0+        _ -> storageTypeSize stp++    -- The smallest magnitude of offset that the load may occur+    -- behind the write pointer.  This is at least the stride of the alignment,+    -- but may also be given by the high bound value of the difference, if it is negative.+    prefixLoBound =+      case bnd of+        Just (_lo, hi)+          | hi < 0 -> adjustLoBound (stride - delta) (toBytes (-hi))+        _ -> stride - delta++    -- The largest magnitude of offset, plus one, that the load may occur+    -- behind the write pointer.  This is at most the length of the read,+    -- but may also be given by the low bound value of the offset difference,+    -- if it is negative.  Note, in the case that @lo@ is positive, the+    -- prefix table will be empty.+    prefixHiBound =+      case bnd of+        Just (lo, _hi)+          | lo < 0    -> min lsz (toBytes (-lo) + 1)+          | otherwise -> 0+        _ -> lsz++    -- Walk through prefix offset values, computing a mux tree of the values+    -- for those prefix loads.+    mkPrefixTable :: Bytes -> Map Bytes (Mux (ValueCtor (ValueLoad OffsetExpr)))+    mkPrefixTable i+      | i < prefixHiBound = Map.insert i+        (MuxVar (fmap adjustFn <$> valueLoad 0 tp i v))+        (mkPrefixTable (i + stride))+      | otherwise = Map.empty+      where adjustFn = fixLoadBeforeStoreOffset pref i++    -- Walk through suffix offset values, computing a mux tree of the values+    -- for those suffix loads.+    mkSuffixTable :: Bytes -> Map Bytes (Mux (ValueCtor (ValueLoad OffsetExpr)))+    mkSuffixTable i+      | i < suffixHiBound =+        Map.insert i+        (MuxVar (fmap adjustFn <$> valueLoad i tp 0 v))+        (mkSuffixTable (i + stride))+      | otherwise = Map.empty+      where adjustFn = fixLoadAfterStoreOffset pref i++    loadFail = MuxVar (ValueCtorVar (OldMemory Load tp))++    adjustLoBound :: Bytes -> Bytes -> Bytes+    adjustLoBound i bound = if i >= bound+      then i+      else adjustLoBound (i + stride) bound++-- | Create a value of the given type made up of copies of the given byte.+memsetValue :: a -> StorageType -> ValueCtor a+memsetValue byte = go+  where+    val = ValueCtorVar byte+    go tp =+      case storageTypeF tp of+        Bitvector sz+          | sz <= 1 -> val+          | otherwise -> concatBV 1 val (sz - 1) (go (bitvectorType (sz - 1)))+        Float -> BVToFloat (go (bitvectorType 4))+        Double -> BVToDouble (go (bitvectorType 8))+        X86_FP80 -> BVToX86_FP80 (go (bitvectorType 10))+        Array n etp -> MkArray etp (V.replicate (fromIntegral n) (go etp))+        Struct flds -> MkStruct (fldFn <$> flds)+          where fldFn fld = (fld, go (fld^.fieldVal))++-- | Create value of type that splits at a particular byte offset.+--+-- This function uses the given 'StorageType' to determine how many bytes to+-- read (including accounting for padding in struct types).  The function to+-- load each byte is provided as an argument.+--+-- NOTE: The 'Offset' argument is not necessarily the offset into the+-- allocation; it *could* be zero if the load function captures the offset into+-- the allocation.+loadTypedValueFromBytes+  :: Offset -- ^ The initial offset to pass to the byte loading function+  -> StorageType -- ^ The type used to compute how many bytes to read+  -> (Offset -> IO a) -- ^ A function to read individual bytes (at the given offset)+  -> IO (ValueCtor a)+loadTypedValueFromBytes off tp subFn = case storageTypeF tp of+  Bitvector size+    | size <= 1 -> ValueCtorVar <$> subFn off+    | otherwise -> do+      head_byte <- ValueCtorVar <$> subFn off+      tail_bytes <- loadTypedValueFromBytes+        (off + 1)+        (bitvectorType (size - 1))+        subFn+      return $ concatBV 1 head_byte (size - 1) tail_bytes+  Float ->+    BVToFloat <$> loadTypedValueFromBytes off (bitvectorType 4) subFn+  Double ->+    BVToDouble <$> loadTypedValueFromBytes off (bitvectorType 8) subFn+  X86_FP80 ->+    BVToX86_FP80 <$> loadTypedValueFromBytes off (bitvectorType 10) subFn+  Array len elem_type -> MkArray elem_type <$> V.generateM+    (fromIntegral len)+    (\idx -> loadTypedValueFromBytes+      (off + (fromIntegral idx) * (storageTypeSize elem_type))+      elem_type+      subFn)+  Struct fields -> MkStruct <$> V.mapM+    (\field -> do+      field_val <- loadTypedValueFromBytes+        (off + (fieldOffset field))+        (field^.fieldVal)+        subFn+      return (field, field_val))+    fields
+ src/Lang/Crucible/LLVM/MemModel/Generic.hs view
@@ -0,0 +1,1808 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Generic+-- Description      : Core definitions of the symbolic C memory model+-- Copyright        : (c) Galois, Inc 2011-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-}++module Lang.Crucible.LLVM.MemModel.Generic+  ( Mem+  , emptyMem+  , AllocType(..)+  , Mutability(..)+  , AllocInfo(..)+  , MemAllocs+  , memAllocs+  , memEndian+  , memAllocCount+  , memWriteCount+  , allocMem+  , allocAndWriteMem+  , readMem+  , isValidPointer+  , isAllocatedMutable+  , isAllocatedAlignedPointer+  , notAliasable+  , writeMem+  , writeConstMem+  , copyMem+  , setMem+  , invalidateMem+  , writeArrayMem+  , writeArrayConstMem+  , pushStackFrameMem+  , popStackFrameMem+  , freeMem+  , branchMem+  , branchAbortMem+  , mergeMem+  , asMemAllocationArrayStore+  , isAligned++  , SomeAlloc(..)+  , possibleAllocs+  , possibleAllocInfo+  , ppSomeAlloc++    -- * Pretty printing+  , ppType+  , ppPtr+  , ppAllocs+  , ppMem+  , ppTermExpr+  ) where++import           Prelude hiding (pred)++import           Control.Lens+import           Control.Monad+import           Control.Monad.State.Strict+import           Data.IORef+import           Data.Maybe+import qualified Data.List as List+import qualified Data.Map as Map+import           Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import           Data.Monoid+import           Data.Text (Text)+import           Numeric.Natural+import           Prettyprinter+import           Lang.Crucible.Panic (panic)++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Classes+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.Ctx (SingleCtx)+import           Data.Parameterized.Some++import           What4.Interface+import qualified What4.Concrete as W4++import           Lang.Crucible.Backend+import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.Errors.MemoryError (MemErrContext, MemoryErrorReason(..), MemoryOp(..))+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.MemModel.CallStack (getCallStack)+import           Lang.Crucible.LLVM.MemModel.Common+import           Lang.Crucible.LLVM.MemModel.Options+import           Lang.Crucible.LLVM.MemModel.MemLog+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemModel.Type+import           Lang.Crucible.LLVM.MemModel.Value+import           Lang.Crucible.LLVM.MemModel.Partial (PartLLVMVal, HasLLVMAnn)+import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial+import           Lang.Crucible.LLVM.Utils+import           Lang.Crucible.Simulator.RegMap (RegValue'(..))++--------------------------------------------------------------------------------+-- Reading from memory++tgAddPtrC :: (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w)+tgAddPtrC sym w x y = ptrAdd sym w x =<< constOffset sym w y++-- | An environment used to interpret 'OffsetExpr's, 'IntExpr's, and 'Cond's.+-- These data structures may contain uninterpreted variables to be filled in+-- with the offset address of a load or store, or the size of the current+-- region. Since regions may be unbounded in size, the size argument is a+-- 'Maybe' type.+data ExprEnv sym w = ExprEnv { loadOffset  :: SymBV sym w+                             , storeOffset :: SymBV sym w+                             , sizeData    :: Maybe (SymBV sym w) }++ppExprEnv :: IsExprBuilder sym => ExprEnv sym w -> Doc ann+ppExprEnv f =+  vcat+  [ "ExprEnv"+  , indent 4 $ vcat+    [ "loadOffset:"  <+> printSymExpr (loadOffset f)+    , "storeOffset:" <+> printSymExpr (storeOffset f)+    , "sizeData:"    <+> maybe mempty printSymExpr (sizeData f)+    ]+  ]++-- | Interpret an 'OffsetExpr' as a 'SymBV'. Although 'OffsetExpr's may contain+-- 'IntExpr's, which may be undefined if they refer to the size of an unbounded+-- memory region, this function will panic if both (1) the 'sizeData'+-- in the 'ExprEnv' is 'Nothing' and (2) 'StoreSize' occurs anywhere in the+-- 'OffsetExpr'.+genOffsetExpr ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  ExprEnv sym w ->+  OffsetExpr ->+  IO (SymBV sym w)+genOffsetExpr sym w f@(ExprEnv load store _size) expr =+  case expr of+    OffsetAdd pe ie -> do+      pe' <- genOffsetExpr sym w f pe+      ie' <- genIntExpr sym w f ie+      case ie' of+        Nothing -> panic "Generic.genOffsetExpr"+                     [ "Cannot construct an offset that references the size of an unbounded region"+                     , "*** Invalid offset expression:  " ++ show expr+                     , "*** Under environment:  " ++ show (ppExprEnv f)+                     ]+        Just ie'' -> bvAdd sym pe' ie''+    Load  -> return load+    Store -> return store++-- | Interpret an 'IntExpr' as a 'SymBV'. If the 'IntExpr' contains an+-- occurrence of 'StoreSize' and the store size in the 'ExprEnv' is unbounded,+-- will return 'Nothing'.+genIntExpr ::+  (1 <= w, IsSymInterface sym) =>+  sym ->+  NatRepr w ->+  ExprEnv sym w ->+  IntExpr ->+  IO (Maybe (SymBV sym w))+genIntExpr sym w f@(ExprEnv _load _store size) expr =+  case expr of+    OffsetDiff e1 e2 -> do+      e1' <- genOffsetExpr sym w f e1+      e2' <- genOffsetExpr sym w f e2+      Just <$> bvSub sym e1' e2'+    IntAdd e1 e2 -> do+      e1' <- genIntExpr sym w f e1+      e2' <- genIntExpr sym w f e2+      case (e1', e2') of+        (Just e1'', Just e2'') -> Just <$> bvAdd sym e1'' e2''+        _                      -> return Nothing -- Unbounded space added to anything is unbounded+    CValue i -> Just <$> bvLit sym w (bytesToBV w i)+    StoreSize -> return size++-- | Interpret a conditional as a symbolic predicate.+genCondVar :: forall sym w.+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  ExprEnv sym w ->+  Cond ->+  IO (Pred sym)+genCondVar sym w inst c =+  case c of+    OffsetEq x y   -> join $ bvEq sym <$> genOffsetExpr sym w inst x <*> genOffsetExpr sym w inst y+    OffsetLe x y   -> join $ bvUle sym <$> genOffsetExpr sym w inst x <*> genOffsetExpr sym w inst y+    IntEq x y      -> join $ maybeBVEq sym <$> genIntExpr sym w inst x <*> genIntExpr sym w inst y+    IntLe x y      -> join $ maybeBVLe sym <$> genIntExpr sym w inst x <*> genIntExpr sym w inst y+    And x y        -> join $ andPred sym <$> genCondVar sym w inst x <*> genCondVar sym w inst y+    Or x y         -> join $ orPred sym <$> genCondVar sym w inst x <*> genCondVar sym w inst y++-- | Compare the equality of two @Maybe SymBV@s+maybeBVEq :: (1 <= w, IsExprBuilder sym)+          => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)+maybeBVEq sym (Just x) (Just y) = bvEq sym x y+maybeBVEq sym Nothing  Nothing  = return $ truePred sym+maybeBVEq sym _        _        = return $ falsePred sym++-- | Compare two @Maybe SymBV@s+maybeBVLe :: (1 <= w, IsExprBuilder sym)+          => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym)+maybeBVLe sym (Just x) (Just y) = bvSle sym x y+maybeBVLe sym _        Nothing  = return $ truePred sym+maybeBVLe sym Nothing  (Just _) = return $ falsePred sym++-- | Given a 'ValueCtor' (of partial LLVM values), recursively traverse the+-- 'ValueCtor' to reconstruct the partial value as directed (while respecting+-- endianness)+genValueCtor :: forall sym w.+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  EndianForm ->+  MemoryOp sym w ->+  ValueCtor (PartLLVMVal sym) ->+  IO (PartLLVMVal sym)+genValueCtor sym end errCtx v =+  case v of+    ValueCtorVar x -> return x+    ConcatBV vcl vch ->+      do vl <- genValueCtor sym end errCtx vcl+         vh <- genValueCtor sym end errCtx vch+         case end of+           BigEndian    -> Partial.bvConcat sym errCtx vh vl+           LittleEndian -> Partial.bvConcat sym errCtx vl vh+    ConsArray vc1 vc2 ->+      do lv1 <- genValueCtor sym end errCtx vc1+         lv2 <- genValueCtor sym end errCtx vc2+         Partial.consArray sym errCtx lv1 lv2+    AppendArray vc1 vc2 ->+      do lv1 <- genValueCtor sym end errCtx vc1+         lv2 <- genValueCtor sym end errCtx vc2+         Partial.appendArray sym errCtx lv1 lv2+    MkArray tp vv ->+      Partial.mkArray sym tp =<<+        traverse (genValueCtor sym end errCtx) vv+    MkStruct vv ->+      Partial.mkStruct sym =<<+        traverse (traverse (genValueCtor sym end errCtx)) vv+    BVToFloat x ->+      Partial.bvToFloat sym errCtx =<< genValueCtor sym end errCtx x+    BVToDouble x ->+      Partial.bvToDouble sym errCtx =<< genValueCtor sym end errCtx x+    BVToX86_FP80 x ->+      Partial.bvToX86_FP80 sym errCtx =<< genValueCtor sym end errCtx x++-- | Compute the actual value of a value deconstructor expression.+applyView ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  EndianForm ->+  MemErrContext sym w ->+  PartLLVMVal sym ->+  ValueView ->+  IO (PartLLVMVal sym)+applyView sym end errCtx t val =+  case val of+    ValueViewVar _ ->+      return t+    SelectPrefixBV i j v ->+      do t' <- applyView sym end errCtx t v+         case end of+           BigEndian    -> Partial.selectHighBv sym errCtx j i t'+           LittleEndian -> Partial.selectLowBv sym errCtx i j t'+    SelectSuffixBV i j v ->+      do t' <- applyView sym end errCtx t v+         case end of+           BigEndian -> Partial.selectLowBv sym errCtx j i t'+           LittleEndian -> Partial.selectHighBv sym errCtx i j t'+    FloatToBV v ->+      Partial.floatToBV sym errCtx =<< applyView sym end errCtx t v+    DoubleToBV v ->+      Partial.doubleToBV sym errCtx =<< applyView sym end errCtx t v+    X86_FP80ToBV v ->+      Partial.fp80ToBV sym errCtx =<< applyView sym end errCtx t v+    ArrayElt sz tp idx v ->+      Partial.arrayElt sym errCtx sz tp idx =<< applyView sym end errCtx t v+    FieldVal flds idx v ->+      Partial.fieldVal sym errCtx flds idx =<< applyView sym end errCtx t v++evalMuxValueCtor ::+  forall u sym w .+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  NatRepr w ->+  EndianForm ->+  MemErrContext sym w ->+  ExprEnv sym w {- ^ Evaluation function -} ->+  (u -> ReadMem sym (PartLLVMVal sym)) {- ^ Function for reading specific subranges -} ->+  Mux (ValueCtor u) ->+  ReadMem sym (PartLLVMVal sym)+evalMuxValueCtor sym _w end errCtx _vf subFn (MuxVar v) =+  do v' <- traverse subFn v+     liftIO $ genValueCtor sym end errCtx v'+evalMuxValueCtor sym w end errCtx vf subFn (Mux c t1 t2) =+  do c' <- liftIO $ genCondVar sym w vf c+     case asConstantPred c' of+       Just True  -> evalMuxValueCtor sym w end errCtx vf subFn t1+       Just False -> evalMuxValueCtor sym w end errCtx vf subFn t2+       Nothing ->+        do t1' <- evalMuxValueCtor sym w end errCtx vf subFn t1+           t2' <- evalMuxValueCtor sym w end errCtx vf subFn t2+           liftIO $ Partial.muxLLVMVal sym c' t1' t2'++evalMuxValueCtor sym w end errCtx vf subFn (MuxTable a b m t) =+  do m' <- traverse (evalMuxValueCtor sym w end errCtx vf subFn) m+     t' <- evalMuxValueCtor sym w end errCtx vf subFn t+     -- TODO: simplification?+     Map.foldrWithKey f (return t') m'+  where+    f :: Bytes -> PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym)+    f n t1 k =+      do c' <- liftIO $ genCondVar sym w vf (OffsetEq (aOffset n) b)+         case asConstantPred c' of+           Just True  -> return t1+           Just False -> k+           Nothing    -> liftIO . Partial.muxLLVMVal sym c' t1 =<< k++    aOffset :: Bytes -> OffsetExpr+    aOffset n = OffsetAdd a (CValue n)++-- | Read from a memory with a memcopy to the same block we are reading.+readMemCopy ::+  forall sym w.+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  NatRepr w ->+  EndianForm ->+  MemoryOp sym w ->+  LLVMPtr sym w  {- ^ The loaded offset               -} ->+  StorageType    {- ^ The type we are reading         -} ->+  SymBV sym w    {- ^ The destination of the memcopy  -} ->+  LLVMPtr sym w  {- ^ The source of the copied region -} ->+  SymBV sym w    {- ^ The length of the copied region -} ->+  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->+  ReadMem sym (PartLLVMVal sym)+readMemCopy sym w end mop (LLVMPointer blk off) tp d src sz readPrev =+  do let ld = BV.asUnsigned <$> asBV off+     let dd = BV.asUnsigned <$> asBV d+     let varFn = ExprEnv off d (Just sz)++     case (ld, dd) of+       -- Offset if known+       (Just lo, Just so) ->+         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') = do+                  o' <- liftIO $ bvLit sym w (bytesToBV w o)+                  readPrev tp' (LLVMPointer blk o')+                subFn (InRange o tp') =+                  readPrev tp' =<< liftIO (tgAddPtrC sym w src o)+            case BV.asUnsigned <$> asBV sz of+              Just csz -> do+                let s = R (fromInteger so) (fromInteger (so + csz))+                let vcr = rangeLoad (fromInteger lo) tp s+                liftIO . genValueCtor sym end mop =<< traverse subFn vcr+              _ ->+                evalMuxValueCtor sym w end mop varFn subFn $+                  fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so)+         -- Symbolic offsets+       _ ->+         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') =+                  do o' <- liftIO $ genOffsetExpr sym w varFn o+                     readPrev tp' (LLVMPointer blk o')+                subFn (InRange o tp') = do+                  oExpr <- liftIO $ genIntExpr sym w varFn o+                  srcPlusO <- case oExpr of+                                Just oExpr' -> liftIO $ ptrAdd sym w src oExpr'+                                Nothing     -> panic "Generic.readMemCopy"+                                                ["Cannot use an unbounded bitvector expression as an offset"+                                                ,"*** In offset epxression:  " ++ show o+                                                ,"*** Under environment:  " ++ show (ppExprEnv varFn)+                                                ]+                  readPrev tp' srcPlusO+            let pref | Just{} <- dd = FixedStore+                     | Just{} <- ld = FixedLoad+                     | otherwise = NeitherFixed+            let mux0 | Just csz <- BV.asUnsigned <$> asBV sz =+                         fixedSizeRangeLoad pref tp (fromInteger csz)+                     | otherwise =+                         symbolicRangeLoad pref tp+            evalMuxValueCtor sym w end mop varFn subFn mux0++readMemSet ::+  forall sym w .+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  NatRepr w ->+  EndianForm ->+  MemoryOp sym w ->+  LLVMPtr sym w {- ^ The loaded offset             -} ->+  StorageType   {- ^ The type we are reading       -} ->+  SymBV sym w   {- ^ The destination of the memset -} ->+  SymBV sym 8   {- ^ The fill byte that was set    -} ->+  SymBV sym w   {- ^ The length of the set region  -} ->+  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->+  ReadMem sym (PartLLVMVal sym)+readMemSet sym w end mop (LLVMPointer blk off) tp d byte sz readPrev =+  do let ld = BV.asUnsigned <$> asBV off+     let dd = BV.asUnsigned <$> asBV d+     let varFn = ExprEnv off d (Just sz)+     case (ld, dd) of+       -- Offset if known+       (Just lo, Just so) ->+         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') = do+                  o' <- liftIO $ bvLit sym w (bytesToBV w o)+                  readPrev tp' (LLVMPointer blk o')+                subFn (InRange   _o tp') = do+                  blk0 <- liftIO $ natLit sym 0+                  let val = LLVMValInt blk0 byte+                  let b   = Partial.totalLLVMVal sym val+                  liftIO $ genValueCtor sym end mop (memsetValue b tp')+            case BV.asUnsigned <$> asBV sz of+              Just csz -> do+                let s = R (fromInteger so) (fromInteger (so + csz))+                let vcr = rangeLoad (fromInteger lo) tp s+                liftIO . genValueCtor sym end mop =<< traverse subFn vcr+              _ -> evalMuxValueCtor sym w end mop varFn subFn $+                     fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so)+       -- Symbolic offsets+       _ ->+         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') =+                  do o' <- liftIO $ genOffsetExpr sym w varFn o+                     readPrev tp' (LLVMPointer blk o')+                subFn (InRange _o tp') = liftIO $+                  do blk0 <- natLit sym 0+                     let val = LLVMValInt blk0 byte+                     let b = Partial.totalLLVMVal sym val+                     genValueCtor sym end mop (memsetValue b tp')+            let pref | Just{} <- dd = FixedStore+                     | Just{} <- ld = FixedLoad+                     | otherwise = NeitherFixed+            let mux0 | Just csz <- BV.asUnsigned <$> asBV sz =+                         fixedSizeRangeLoad pref tp (fromInteger csz)+                     | otherwise =+                         symbolicRangeLoad pref tp+            evalMuxValueCtor sym w end mop varFn subFn mux0++-- | Read from a memory with a store to the same block we are reading.+readMemStore ::+  forall sym w.+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  NatRepr w ->+  EndianForm ->+  MemoryOp sym w ->+  LLVMPtr sym w {- ^ The loaded address                 -} ->+  StorageType   {- ^ The type we are reading            -} ->+  SymBV sym w   {- ^ The destination of the store       -} ->+  LLVMVal sym   {- ^ The value that was stored          -} ->+  StorageType   {- ^ The type of value that was written -} ->+  Alignment     {- ^ The alignment of the pointer we are reading from -} ->+  Alignment     {- ^ The alignment of the store from which we are reading -} ->+  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))+  {- ^ A callback function for when reading fails -} ->+  ReadMem sym (PartLLVMVal sym)+readMemStore sym w end mop (LLVMPointer blk off) ltp d t stp loadAlign storeAlign readPrev =+  do ssz <- liftIO $ bvLit sym w (bytesToBV w (storageTypeSize stp))+     let varFn = ExprEnv off d (Just ssz)+     let ld = BV.asUnsigned <$> asBV off+     let dd = BV.asUnsigned <$> asBV d+     case (ld, dd) of+       -- Offset if known+       (Just lo, Just so) ->+         do let subFn :: ValueLoad Addr -> ReadMem sym (PartLLVMVal sym)+                subFn (OldMemory o tp')  =+                  readPrev tp' . LLVMPointer blk =<<+                    liftIO (bvLit sym w (bytesToBV w o))+                subFn (LastStore v)      = liftIO $+                  applyView sym end mop (Partial.totalLLVMVal sym t) v+                subFn (InvalidMemory tp) = liftIO (Partial.partErr sym mop $ Invalid tp)+            let vcr = valueLoad (fromInteger lo) ltp (fromInteger so) (ValueViewVar stp)+            liftIO . genValueCtor sym end mop =<< traverse subFn vcr+       -- Symbolic offsets+       _ ->+         do let subFn :: ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym)+                subFn (OldMemory o tp')  = do+                  o' <- liftIO $ genOffsetExpr sym w varFn o+                  readPrev tp' (LLVMPointer blk o')+                subFn (LastStore v)      = liftIO $+                  applyView sym end mop (Partial.totalLLVMVal sym t) v+                subFn (InvalidMemory tp) = liftIO (Partial.partErr sym mop $ Invalid tp)+            let pref | Just{} <- dd = FixedStore+                     | Just{} <- ld = FixedLoad+                     | otherwise = NeitherFixed++            let alignStride = fromAlignment $ min loadAlign storeAlign++            -- compute the linear form of (load offset - store offset)+            let (diffStride, diffDelta)+                  | Just (load_a, _x, load_b) <- asAffineVar off+                  , Just (store_a, _y, store_b) <- asAffineVar d = do+                    let stride' = gcd+                          (BV.asUnsigned (W4.fromConcreteBV load_a))+                          (BV.asUnsigned (W4.fromConcreteBV store_a))+                    -- mod returns a non-negative integer+                    let delta' = mod+                          (BV.asUnsigned (W4.fromConcreteBV load_b) -+                           BV.asUnsigned (W4.fromConcreteBV store_b))+                          stride'+                    (fromInteger stride', fromInteger delta')+                  | Just (load_a, _x, load_b) <- asAffineVar off+                  , Just store_b <- BV.asUnsigned <$> asBV d = do+                    let stride' = BV.asUnsigned (W4.fromConcreteBV load_a)+                    let delta' = mod (BV.asUnsigned (W4.fromConcreteBV load_b) - store_b) stride'+                    (fromInteger stride', fromInteger delta')+                  | Just load_b <- BV.asUnsigned <$> asBV off+                  , Just (store_a, _y, store_b) <- asAffineVar d = do+                    let stride' = BV.asUnsigned (W4.fromConcreteBV store_a)+                    let delta' = mod (load_b - BV.asUnsigned (W4.fromConcreteBV store_b)) stride'+                    (fromInteger stride', fromInteger delta')+                  | otherwise = (1, 0)++            let (stride, delta) = if diffStride >= alignStride+                  then (diffStride, diffDelta)+                  else (alignStride, 0)++            diff <- liftIO $ bvSub sym off d++            -- skip computing the mux tree if it would be empty+            if storageTypeSize stp <= delta && (typeEnd 0 ltp) <= (stride - delta)+              then readPrev ltp $ LLVMPointer blk off+              else evalMuxValueCtor sym w end mop varFn subFn $+                symbolicValueLoad+                  pref+                  ltp+                  (signedBVBounds diff)+                  (ValueViewVar stp)+                  (LinearLoadStoreOffsetDiff stride delta)++-- | Read from a memory with an array store to the same block we are reading.+--+-- NOTE: This case should only fire if a write is straddling an array store and+-- another write, as the top-level case of 'readMem' should handle the case+-- where a read is completely covered by a write to an array.+readMemArrayStore+  :: forall sym w+   . (1 <= w, IsSymInterface sym, HasLLVMAnn sym)+  => sym+  -> NatRepr w+  -> EndianForm+  -> MemoryOp sym w+  -> LLVMPtr sym w {- ^ The loaded offset -}+  -> StorageType {- ^ The type we are reading -}+  -> SymBV sym w {- ^ The offset of the mem array store from the base pointer -}+  -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ The stored array -}+  -> Maybe (SymBV sym w) {- ^ The length of the stored array -}+  -> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym))+  -> ReadMem sym (PartLLVMVal sym)+readMemArrayStore sym w end mop (LLVMPointer blk read_off) tp write_off arr size read_prev = do+  let loadFn :: SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym)+      loadFn base tp' = liftIO $ do+        let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym)+            loadArrayByteFn off = do+              blk0 <- natLit sym 0+              idx <- bvAdd sym base =<< bvLit sym w (bytesToBV w off)+              byte <- arrayLookup sym arr $ Ctx.singleton idx+              return $ Partial.totalLLVMVal sym $ LLVMValInt blk0 byte+        genValueCtor sym end mop =<< loadTypedValueFromBytes 0 tp' loadArrayByteFn+  let varFn = ExprEnv read_off write_off size+  case (BV.asUnsigned <$> asBV read_off, BV.asUnsigned <$> asBV write_off) of+    -- In this case, both the read and write offsets are concrete+    (Just lo, Just so) -> do+      let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)+          subFn = \case+            OutOfRange o tp' -> do+              o' <- liftIO $ bvLit sym w $ bytesToBV w o+              read_prev tp' $ LLVMPointer blk o'+            InRange o tp' -> do+              o' <- liftIO $ bvLit sym w $ bytesToBV w o+              loadFn o' tp'+      case BV.asUnsigned <$> (asBV =<< size) of+        -- The size of the backing SMT array is also concrete, so we can generate a mux-free value+        Just concrete_size -> do+          let s = R (fromInteger so) (fromInteger (so + concrete_size))+          let vcr = rangeLoad (fromInteger lo) tp s+          liftIO . genValueCtor sym end mop =<< traverse subFn vcr+        -- Otherwise, the size of the array is unbounded or symbolic+        --+        -- The generated mux covers the possible cases where the read straddles+        -- the store in various configurations+        --+        -- FIXME/Question: Does this properly handle the unbounded array case? Does it+        -- need special handling of that case at all?+        _ -> evalMuxValueCtor sym w end mop varFn subFn $+          fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so)+    -- Otherwise, at least one of the offsets is symbolic (and we will have to generate additional muxes)+    _ -> do+      let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)+          subFn = \case+            OutOfRange o tp' -> do+              o' <- liftIO $ genOffsetExpr sym w varFn o+              read_prev tp' $ LLVMPointer blk o'+            InRange o tp' -> do+              o' <- liftIO $ genIntExpr sym w varFn o+              -- should always produce a defined value+              case o' of+                Just o'' -> loadFn o'' tp'+                Nothing  -> panic "Generic.readMemArrayStore"+                              [ "Unexpected unbounded size in RangeLoad"+                              , "*** Integer expression:  " ++ show o+                              , "*** Under environment:  " ++ show (ppExprEnv varFn)+                              ]+      let pref+            | Just{} <- BV.asUnsigned <$> asBV write_off = FixedStore+            | Just{} <- BV.asUnsigned <$> asBV read_off = FixedLoad+            | otherwise = NeitherFixed+      let rngLd+            -- if the size of the data is bounded, use symbolicRangeLoad+            | Just _  <- size = symbolicRangeLoad pref tp+            -- otherwise, use symbolicUnboundedRangeLoad+            | Nothing <- size = symbolicUnboundedRangeLoad pref tp+      evalMuxValueCtor sym w end mop varFn subFn rngLd++readMemInvalidate ::+  forall sym w .+  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  sym -> NatRepr w ->+  EndianForm ->+  MemoryOp sym w ->+  LLVMPtr sym w {- ^ The loaded offset                   -} ->+  StorageType   {- ^ The type we are reading             -} ->+  SymBV sym w   {- ^ The destination of the invalidation -} ->+  Text          {- ^ The error message                   -} ->+  SymBV sym w   {- ^ The length of the set region        -} ->+  (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->+  ReadMem sym (PartLLVMVal sym)+readMemInvalidate sym w end mop (LLVMPointer blk off) tp d msg sz readPrev =+  do let ld = BV.asUnsigned <$> asBV off+     let dd = BV.asUnsigned <$> asBV d+     let varFn = ExprEnv off d (Just sz)+     case (ld, dd) of+       -- Offset if known+       (Just lo, Just so) ->+         do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') = do+                  o' <- liftIO $ bvLit sym w (bytesToBV w o)+                  readPrev tp' (LLVMPointer blk o')+                subFn (InRange _o tp') =+                  readInRange tp'+            case BV.asUnsigned <$> asBV sz of+              Just csz -> do+                let s = R (fromInteger so) (fromInteger (so + csz))+                let vcr = rangeLoad (fromInteger lo) tp s+                liftIO . genValueCtor sym end mop =<< traverse subFn vcr+              _ -> evalMuxValueCtor sym w end mop varFn subFn $+                     fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so)+       -- Symbolic offsets+       _ ->+         do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym)+                subFn (OutOfRange o tp') = do+                  o' <- liftIO $ genOffsetExpr sym w varFn o+                  readPrev tp' (LLVMPointer blk o')+                subFn (InRange _o tp') =+                  readInRange tp'+            let pref | Just{} <- dd = FixedStore+                     | Just{} <- ld = FixedLoad+                     | otherwise = NeitherFixed+            let mux0 | Just csz <- BV.asUnsigned <$> asBV sz =+                         fixedSizeRangeLoad pref tp (fromInteger csz)+                     | otherwise =+                         symbolicRangeLoad pref tp+            evalMuxValueCtor sym w end mop varFn subFn mux0+  where+    readInRange :: StorageType -> ReadMem sym (PartLLVMVal sym)+    readInRange tp'+      | laxLoadsAndStores ?memOpts &&+        indeterminateLoadBehavior ?memOpts == UnstableSymbolic+      = liftIO (Partial.totalLLVMVal sym <$> freshLLVMVal sym tp')+      | otherwise+      = liftIO (Partial.partErr sym mop $ Invalidated msg)++-- | Read a value from memory.+readMem :: forall sym w.+  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  sym ->+  NatRepr w ->+  Maybe String ->+  LLVMPtr sym w ->+  StorageType ->+  Alignment ->+  Mem sym ->+  IO (PartLLVMVal sym)+readMem sym w gsym l tp alignment m = do+  sz         <- bvLit sym w (bytesToBV w (typeEnd 0 tp))+  p1         <- isAllocated sym w alignment l (Just sz) m+  p2         <- isAligned sym w l alignment+  maybe_allocation_array <- asMemAllocationArrayStore sym w l m++  let mop = MemLoadOp tp gsym l m++  part_val <- case maybe_allocation_array of+    -- If this read is inside an allocation backed by a SMT array store,+    -- then decompose this read into reading the individual bytes and+    -- assembling them to obtain the value, without introducing any+    -- ite operations+    Just (ok, arr, _arr_sz) | Just True <- asConstantPred ok -> do+      let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym)+          loadArrayByteFn off = do+            blk0 <- natLit sym 0+            idx <- bvAdd sym (llvmPointerOffset l)+              =<< bvLit sym w (bytesToBV w off)+            byte <- arrayLookup sym arr $ Ctx.singleton idx+            return $ Partial.totalLLVMVal sym $ LLVMValInt blk0 byte+      genValueCtor sym (memEndianForm m) mop+        =<< loadTypedValueFromBytes 0 tp loadArrayByteFn+    -- Otherwise, fall back to the less-optimized read case+    _ -> readMem' sym w (memEndianForm m) gsym l m tp alignment (memWrites m)++  let stack = getCallStack (m ^. memState)+  part_val' <- applyUnless (laxLoadsAndStores ?memOpts)+                           (Partial.attachSideCondition sym stack p2 (UB.ReadBadAlignment (RV l) alignment))+                           part_val+  applyUnless (laxLoadsAndStores ?memOpts)+              (Partial.attachMemoryError sym p1 mop UnreadableRegion)+              part_val'++data CacheEntry sym w =+  CacheEntry !(StorageType) !(SymNat sym) !(SymBV sym w)++instance (TestEquality (SymExpr sym)) => Eq (CacheEntry sym w) where+  (CacheEntry tp1 blk1 off1) == (CacheEntry tp2 blk2 off2) =+    tp1 == tp2 && (blk1 == blk2) && (isJust $ testEquality off1 off2)++instance IsSymInterface sym => Ord (CacheEntry sym w) where+  compare (CacheEntry tp1 blk1 off1) (CacheEntry tp2 blk2 off2) =+    compare tp1 tp2+      `mappend` compare blk1 blk2+      `mappend` toOrdering (compareF off1 off2)++toCacheEntry :: StorageType -> LLVMPtr sym w -> CacheEntry sym w+toCacheEntry tp (llvmPointerView -> (blk, bv)) = CacheEntry tp blk bv+++-- | Read a value from memory given a list of writes.+--+-- Note that the case where a read is entirely backed by an SMT array store is+-- handled in 'readMem'.+readMem' ::+  forall w sym.+  ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  sym ->+  NatRepr w ->+  EndianForm ->+  Maybe String ->+  LLVMPtr sym w  {- ^ Address we are reading            -} ->+  Mem sym        {- ^ The original memory state         -} ->+  StorageType    {- ^ The type to read from memory      -} ->+  Alignment      {- ^ Alignment of pointer to read from -} ->+  MemWrites sym  {- ^ List of writes                    -} ->+  IO (PartLLVMVal sym)+readMem' sym w end gsym l0 origMem tp0 alignment (MemWrites ws) =+   do runReadMem (go fallback0 l0 tp0 [] ws)+  where+    mop = MemLoadOp tp0 gsym l0 origMem++    fallback0 ::+      StorageType ->+      LLVMPtr sym w ->+      ReadMem sym (PartLLVMVal sym)+    fallback0 tp _l =+      liftIO $+        if laxLoadsAndStores ?memOpts+           && indeterminateLoadBehavior ?memOpts == UnstableSymbolic+        then Partial.totalLLVMVal sym <$> freshLLVMVal sym tp+        else do -- We're playing a trick here.  By making a fresh constant a proof obligation, we can be+                -- sure it always fails.  But, because it's a variable, it won't be constant-folded away+                -- and we can be relatively sure the annotation will survive.+                b <- freshConstant sym (safeSymbol "noSatisfyingWrite") BaseBoolRepr+                Partial.Err <$>+                  Partial.annotateME sym mop (NoSatisfyingWrite tp) b++    go :: (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) ->+          LLVMPtr sym w ->+          StorageType ->+          [MemWrite sym] ->+          [MemWritesChunk sym] ->+          ReadMem sym (PartLLVMVal sym)+    go fallback l tp [] [] = fallback tp l+    go fallback l tp [] (head_chunk : tail_chunks) =+      go fallback l tp (memWritesChunkAt l head_chunk) tail_chunks+    go fallback l tp (h : r) rest_chunks =+      do cache <- liftIO $ newIORef Map.empty+         let readPrev ::+               StorageType ->+               LLVMPtr sym w ->+               ReadMem sym (PartLLVMVal sym)+             readPrev tp' l' = do+               m <- liftIO $ readIORef cache+               case Map.lookup (toCacheEntry tp' l') m of+                 Just x -> return x+                 Nothing -> do+                   x <- go fallback l' tp' r rest_chunks+                   liftIO $ writeIORef cache $ Map.insert (toCacheEntry tp' l') x m+                   return x+         case h of+           WriteMerge _ (MemWrites []) (MemWrites []) ->+             go fallback l tp r rest_chunks+           WriteMerge c (MemWrites xr) (MemWrites yr) ->+             do x <- go readPrev l tp [] xr+                y <- go readPrev l tp [] yr+                liftIO $ Partial.muxLLVMVal sym c x y+           MemWrite dst wsrc ->+             case testEquality (ptrWidth dst) w of+               Nothing   -> readPrev tp l+               Just Refl ->+                 do let LLVMPointer blk1 _ = l+                    let LLVMPointer blk2 d = dst+                    let readCurrent =+                          case wsrc of+                            MemCopy src sz -> readMemCopy sym w end mop l tp d src sz readPrev+                            MemSet v sz    -> readMemSet sym w end mop l tp d v sz readPrev+                            MemStore v stp storeAlign -> readMemStore sym w end mop l tp d v stp alignment storeAlign readPrev+                            MemArrayStore arr sz -> readMemArrayStore sym w end mop l tp d arr sz readPrev+                            MemInvalidate msg sz -> readMemInvalidate sym w end mop l tp d msg sz readPrev+                    sameBlock <- liftIO $ natEq sym blk1 blk2+                    case asConstantPred sameBlock of+                      Just True  -> do+                        result <- readCurrent+                        pure result+                      Just False -> readPrev tp l+                      Nothing ->+                        do x <- readCurrent+                           y <- readPrev tp l+                           liftIO $ Partial.muxLLVMVal sym sameBlock x y++--------------------------------------------------------------------------------++-- | Dummy newtype for now...+--   It may be useful later to add additional plumbing+--   to this monad.+newtype ReadMem sym a = ReadMem { runReadMem :: IO a }+  deriving (Applicative, Functor, Monad, MonadIO)+++--------------------------------------------------------------------------------++memWritesSize :: MemWrites sym -> Int+memWritesSize (MemWrites writes) = getSum $ foldMap+  (\case+    MemWritesChunkIndexed indexed_writes ->+      foldMap (Sum . length) indexed_writes+    MemWritesChunkFlat flat_writes -> Sum $ length flat_writes)+  writes++muxChanges :: IsExpr (SymExpr sym) => Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym+muxChanges c (left_allocs, lhs_writes) (rhs_allocs, rhs_writes) =+  ( muxMemAllocs c left_allocs rhs_allocs+  , muxWrites c lhs_writes rhs_writes+  )++muxWrites :: IsExpr (SymExpr sym) => Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym+muxWrites _ (MemWrites []) (MemWrites []) = MemWrites []++muxWrites c lhs_writes rhs_writes+  | Just b <- asConstantPred c = if b then lhs_writes else rhs_writes++muxWrites c lhs_writes rhs_writes+  | Just lhs_indexed_writes <- asIndexedChunkMap lhs_writes+  , Just rhs_indexed_writes <- asIndexedChunkMap rhs_writes =+      MemWrites+        [ MemWritesChunkIndexed $+            mergeMemWritesChunkIndexed+              (\lhs rhs ->+                 [ WriteMerge+                     c+                     (MemWrites [MemWritesChunkFlat lhs])+                     (MemWrites [MemWritesChunkFlat rhs])+                 ])+              lhs_indexed_writes+              rhs_indexed_writes+        ]+  | otherwise =+    MemWrites [MemWritesChunkFlat [WriteMerge c lhs_writes rhs_writes]]+  where asIndexedChunkMap :: MemWrites sym -> Maybe (IntMap [MemWrite sym])+        asIndexedChunkMap (MemWrites [MemWritesChunkIndexed m]) = Just m+        asIndexedChunkMap (MemWrites []) = Just IntMap.empty+        asIndexedChunkMap _ = Nothing++mergeMemWritesChunkIndexed ::+  ([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]) ->+  IntMap [MemWrite sym] ->+  IntMap [MemWrite sym] ->+  IntMap [MemWrite sym]+mergeMemWritesChunkIndexed merge_func = IntMap.mergeWithKey+  (\_ lhs_alloc_writes rhs_alloc_writes -> Just $+    merge_func lhs_alloc_writes rhs_alloc_writes)+  (IntMap.map $ \lhs_alloc_writes -> merge_func lhs_alloc_writes [])+  (IntMap.map $ \rhs_alloc_writes -> merge_func [] rhs_alloc_writes)++memChanges :: Monoid m => (MemChanges sym -> m) -> Mem sym -> m+memChanges f m = go (m^.memState)+  where go (EmptyMem _ _ l)      = f l+        go (StackFrame _ _ _ l s)  = f l <> go s+        go (BranchFrame _ _ l s) = f l <> go s++memAllocs :: Mem sym -> MemAllocs sym+memAllocs = memChanges fst++memWrites :: Mem sym -> MemWrites sym+memWrites = memChanges snd++memWritesChunkAt ::+  IsExprBuilder sym =>+  LLVMPtr sym w ->+  MemWritesChunk sym ->+  [MemWrite sym]+memWritesChunkAt ptr = \case+  MemWritesChunkIndexed indexed_writes+    | Just blk <- asNat (llvmPointerBlock ptr) ->+      IntMap.findWithDefault [] (fromIntegral blk) indexed_writes+    | otherwise -> IntMap.foldr (++) [] indexed_writes+  MemWritesChunkFlat flat_writes -> flat_writes++memWritesAtConstant :: Natural -> MemWrites sym -> [MemWrite sym]+memWritesAtConstant blk (MemWrites writes) = foldMap+  (\case+    MemWritesChunkIndexed indexed_writes ->+      IntMap.findWithDefault [] (fromIntegral blk) indexed_writes+    MemWritesChunkFlat flat_writes -> flat_writes)+  writes++memStateAllocCount :: MemState sym -> Int+memStateAllocCount s = case s of+  EmptyMem ac _ _ -> ac+  StackFrame ac _ _ _ _ -> ac+  BranchFrame ac _ _ _ -> ac++memStateWriteCount :: MemState sym -> Int+memStateWriteCount s = case s of+  EmptyMem _ wc _ -> wc+  StackFrame _ wc _ _ _ -> wc+  BranchFrame _ wc _ _ -> wc++memAllocCount :: Mem sym -> Int+memAllocCount m = memStateAllocCount (m ^. memState)++memWriteCount :: Mem sym -> Int+memWriteCount m = memStateWriteCount (m ^. memState)++memAddAlloc :: (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym+memAddAlloc f = memState %~ \case+  EmptyMem ac wc (a, w) -> EmptyMem (ac+1) wc (f a, w)+  StackFrame ac wc nm (a, w) s -> StackFrame (ac+1) wc nm (f a, w) s+  BranchFrame ac wc (a, w) s -> BranchFrame (ac+1) wc (f a, w) s++memAddWrite ::+  (IsExprBuilder sym, 1 <= w) =>+  LLVMPtr sym w ->+  WriteSource sym w ->+  Mem sym ->+  Mem sym+memAddWrite ptr src = do+  let single_write = memWritesSingleton ptr src+  memState %~ \case+    EmptyMem ac wc (a, w) ->+      EmptyMem ac (wc+1) (a, single_write <> w)+    StackFrame ac wc nm (a, w) s ->+      StackFrame ac (wc+1) nm (a, single_write <> w) s+    BranchFrame ac wc (a, w) s ->+      BranchFrame ac (wc+1) (a, single_write <> w) s++memStateAddChanges :: MemChanges sym -> MemState sym -> MemState sym+memStateAddChanges (a, w) = \case+  EmptyMem ac wc (a0, w0) ->+    EmptyMem (sizeMemAllocs a + ac) (memWritesSize w + wc) (a <> a0, w <> w0)+  StackFrame ac wc nm (a0, w0) s ->+    StackFrame (sizeMemAllocs a + ac) (memWritesSize w + wc) nm (a <> a0, w <> w0) s+  BranchFrame ac wc (a0, w0) s ->+    BranchFrame (sizeMemAllocs a + ac) (memWritesSize w + wc) (a <> a0, w <> w0) s+++--------------------------------------------------------------------------------+-- Pointer validity++-- | @isAllocatedMut isMut sym w p sz m@ returns the condition required to+-- prove range @[p..p+sz)@ lies within a single allocation in @m@.+--+-- This function is parameterized by a predicate on the mutability, so+-- it can optionally be restricted to mutable regions only.+-- It is also parameterized by a required alignment; only allocations+-- with at least this level of alignment are considered.+--+-- NB this algorithm is set up to explicitly allow both zero size allocations+-- and zero-size chunks to be checked for validity.  When 'sz' is 0, every pointer+-- that is inside the range of the allocation OR ONE PAST THE END are considered+-- "allocated"; this is intended, as it captures C's behavior regarding valid+-- pointers.+isAllocatedMut ::+  forall sym w .+  (1 <= w, IsSymInterface sym) =>+  (Mutability -> Bool) ->+  sym -> NatRepr w     ->+  Alignment            ->+  LLVMPtr sym w        ->+  Maybe (SymBV sym w)  ->+  Mem sym              ->+  IO (Pred sym)+isAllocatedMut mutOk sym w minAlign (llvmPointerView -> (blk, off)) sz m =+  do (wasAllocated, notFreed) <- isAllocatedGeneric sym inAllocation blk (memAllocs m)+     andPred sym wasAllocated notFreed+  where+    inAllocation :: AllocInfo sym -> IO (Pred sym)+    inAllocation (AllocInfo _ asz mut alignment _)+      | mutOk mut && alignment >= minAlign = inBounds asz+      | otherwise = pure (falsePred sym)++    -- @inBounds a allocatedSz@ produces the predicate that+    -- records whether the pointer @ptr@ of size @sz@ falls within the+    -- allocation of block @a@ of size @allocatedSz@.+    inBounds :: forall w'. Maybe (SymBV sym w') -> IO (Pred sym)+    inBounds Nothing =+      case sz of+        Nothing ->+          -- Unbounded access of an unbounded allocation must start at offset 0.+          bvEq sym off =<< bvLit sym w (BV.zero w)+        Just currSize ->+          -- Bounded access of an unbounded allocation requires that+          -- @offset + size <= 2^w@, or equivalently @offset <= 2^w -+          -- size@. Note that @bvNeg sym size@ computes @2^w - size@+          -- for any nonzero @size@.+          do zeroSize <- bvEq sym currSize =<< bvLit sym w (BV.zero w)+             noWrap <- bvUle sym off =<< bvNeg sym currSize+             orPred sym zeroSize noWrap++    inBounds (Just allocSize)+      -- If the allocation is done at pointer width is equal to @w@, check+      -- if this allocation covers the required range+      | Just Refl <- testEquality w (bvWidth allocSize)+      , Just currSize <- sz =+        do smallSize <- bvUle sym currSize allocSize    -- currSize <= allocSize+           maxOffset <- bvSub sym allocSize currSize    -- maxOffset = allocSize - currSize+           inRange   <- bvUle sym off maxOffset         -- offset(ptr) <= maxOffset+           andPred sym smallSize inRange++    inBounds (Just _allocSize)+      -- If the allocation is done at pointer width not equal to @w@,+      -- then this is not the allocation we're looking for. Similarly,+      -- if @sz@ is @Nothing@ (indicating we are accessing the entire+      -- address space) then any bounded allocation is too small.+      | otherwise = return $ falsePred sym++-- | @isAllocated sym w p sz m@ returns the condition required to prove+-- range @[p..p+sz)@ lies within a single allocation in @m@.+--+-- NB this algorithm is set up to explicitly allow both zero size allocations+-- and zero-size chunks to be checked for validity.  When 'sz' is 0, every pointer+-- that is inside the range of the allocation OR ONE PAST THE END are considered+-- "allocated"; this is intended, as it captures C's behavior regarding valid+-- pointers.+isAllocated ::+  forall sym w. (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  Alignment        ->+  LLVMPtr sym w    ->+  Maybe (SymBV sym w) ->+  Mem sym          ->+  IO (Pred sym)+isAllocated = isAllocatedMut (const True)++-- | @isAllocatedMutable sym w p sz m@ returns the condition required+-- to prove range @[p..p+sz)@ lies within a single /mutable/+-- allocation in @m@.+isAllocatedMutable ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)+isAllocatedMutable = isAllocatedMut (== Mutable)++-- | Return the condition required to prove that the pointer points to+-- a range of 'size' bytes that falls within an allocated region of+-- the appropriate mutability, and also that the pointer is+-- sufficiently aligned.+isAllocatedAlignedPointer ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  Alignment           {- ^ minimum required pointer alignment                 -} ->+  Mutability          {- ^ 'Mutable' means pointed-to region must be writable -} ->+  LLVMPtr sym w       {- ^ pointer                                            -} ->+  Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space)        -} ->+  Mem sym             {- ^ memory                                             -} ->+  IO (Pred sym)+isAllocatedAlignedPointer sym w alignment mutability ptr size mem =+  do p1 <- isAllocatedMut mutOk sym w alignment ptr size mem+     p2 <- isAligned sym w ptr alignment+     andPred sym p1 p2+  where+    mutOk m =+      case mutability of+        Mutable -> m == Mutable+        Immutable -> True++-- | @isValidPointer sym w b m@ returns the condition required to prove that @p@+--   is a valid pointer in @m@. This means that @p@ is in the range of some+--   allocation OR ONE PAST THE END of an allocation. In other words @p@ is a+--   valid pointer if @b <= p <= b+sz@ for some allocation at base @b@ of size+--   @Just sz@, or if @b <= p@ for some allocation of size @Nothing@. Note that,+--   even though @b+sz@ is outside the allocation range of the allocation+--   (loading through it will fail) it is nonetheless a valid pointer value.+--   This strange special case is baked into the C standard to allow certain+--   common coding patterns to be defined.+isValidPointer :: (1 <= w, IsSymInterface sym)+        => sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym)+isValidPointer sym w p m = do+   sz <- constOffset sym w 0+   isAllocated sym w noAlignment p (Just sz) m+   -- NB We call isAllocated with a size of 0.++-- | Generate a predicate asserting that the given pointer satisfies+-- the specified alignment constraint.+isAligned ::+  forall sym w .+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  LLVMPtr sym w ->+  Alignment ->+  IO (Pred sym)+isAligned sym _w _p a+  | a == noAlignment = return (truePred sym)+isAligned sym w (LLVMPointer _blk offset) a+  | Some bits <- mkNatRepr (alignmentToExponent a)+  , Just LeqProof <- isPosNat bits+  , Just LeqProof <- testLeq bits w =+    do lowbits <- bvSelect sym (knownNat :: NatRepr 0) bits offset+       bvEq sym lowbits =<< bvLit sym bits (BV.zero bits)+isAligned sym _ _ _ =+  return (falsePred sym)++-- | The LLVM memory model generally does not allow for different+-- memory regions to alias each other: Pointers with different+-- allocation block numbers will compare as definitely unequal.+-- However, it does allow two /immutable/ memory regions to alias each+-- other. To make this sound, equality comparisons between pointers to+-- different immutable memory regions must not evaluate to false.+-- Therefore pointer equality comparisons assert that the pointers are+-- not aliasable: they must not point to two different immutable+-- blocks.+notAliasable ::+  forall sym w .+  (IsSymInterface sym) =>+  sym ->+  LLVMPtr sym w ->+  LLVMPtr sym w ->+  Mem sym ->+  IO (Pred sym)+notAliasable sym (llvmPointerView -> (blk1, _)) (llvmPointerView -> (blk2, _)) mem =+  do p0 <- natEq sym blk1 blk2+     (wasAllocated1, notFreed1) <- isAllocatedGeneric sym isMutable blk1 (memAllocs mem)+     (wasAllocated2, notFreed2) <- isAllocatedGeneric sym isMutable blk2 (memAllocs mem)+     allocated1 <- andPred sym wasAllocated1 notFreed1+     allocated2 <- andPred sym wasAllocated2 notFreed2+     orPred sym p0 =<< orPred sym allocated1 allocated2+  where+    isMutable :: AllocInfo sym -> IO (Pred sym)+    isMutable (AllocInfo _ _ Mutable _ _) = pure (truePred sym)+    isMutable (AllocInfo _ _ Immutable _ _) = pure (falsePred sym)++--------------------------------------------------------------------------------+-- Other memory operations++-- | Write a value to memory.+--+-- The returned predicates assert (in this order):+--  * the pointer falls within an allocated, mutable memory region+--  * the pointer's alignment is correct+writeMem :: ( 1 <= w+            , IsSymInterface sym+            , HasLLVMAnn sym+            , ?memOpts :: MemOptions )+         => sym -> NatRepr w+         -> Maybe String+         -> LLVMPtr sym w+         -> StorageType+         -> Alignment+         -> LLVMVal sym+         -> Mem sym+         -> IO (Mem sym, Pred sym, Pred sym)+writeMem = writeMemWithAllocationCheck isAllocatedMutable++-- | Write a value to any memory region, mutable or immutable.+--+-- The returned predicates assert (in this order):+--  * the pointer falls within an allocated memory region+--  * the pointer's alignment is correct+writeConstMem ::+  ( 1 <= w+  , IsSymInterface sym+  , HasLLVMAnn sym+  , ?memOpts :: MemOptions ) =>+  sym           ->+  NatRepr w     ->+  Maybe String  ->+  LLVMPtr sym w ->+  StorageType   ->+  Alignment     ->+  LLVMVal sym   ->+  Mem sym       ->+  IO (Mem sym, Pred sym, Pred sym)+writeConstMem = writeMemWithAllocationCheck isAllocated++-- | Write a value to memory.+--+-- The returned predicates assert (in this order):+--  * the pointer satisfies the checks specified by+--    the @is_allocated@ function+--  * the pointer's alignment is correct+writeMemWithAllocationCheck ::+  forall sym w .+  ( IsSymInterface sym+  , HasLLVMAnn sym+  , 1 <= w+  , ?memOpts :: MemOptions ) =>+  (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) ->+  sym ->+  NatRepr w ->+  Maybe String ->+  LLVMPtr sym w ->+  StorageType ->+  Alignment ->+  LLVMVal sym ->+  Mem sym ->+  IO (Mem sym, Pred sym, Pred sym)+writeMemWithAllocationCheck is_allocated sym w gsym ptr tp alignment val mem = do+  let mop = MemStoreOp tp gsym ptr mem+  let sz = typeEnd 0 tp+  sz_bv <- constOffset sym w sz+  p1 <- is_allocated sym w alignment ptr (Just sz_bv) mem+  p2 <- isAligned sym w ptr alignment+  maybe_allocation_array <- asMemAllocationArrayStore sym w ptr mem+  mem' <- case maybe_allocation_array of+    -- if this write is inside an allocation backed by a SMT array store and+    -- the value is not a pointer, then decompose this write into disassembling+    -- the value to individual bytes, writing them in the SMT array, and+    -- writing the updated SMT array in the memory+    Just (ok, arr, arr_sz) | Just True <- asConstantPred ok+                           , case val of+                               LLVMValInt block _ -> (asNat block) == (Just 0)+                               _ -> True -> do+      let -- Return @Just value@ if we have successfully loaded a value and+          -- should update the corresponding index in the array with that+          -- value. Return @Nothing@ otherwise.+          subFn :: ValueLoad Addr -> IO (Maybe (PartLLVMVal sym))+          subFn = \case+            LastStore val_view -> fmap Just $ applyView+              sym+              (memEndianForm mem)+              mop+              (Partial.totalLLVMVal sym val)+              val_view+            InvalidMemory tp'+              |  -- With stable-symbolic, loading struct padding is+                 -- permissible. This is the only case that can return+                 -- Nothing.+                 laxLoadsAndStores ?memOpts+              ,  indeterminateLoadBehavior ?memOpts == StableSymbolic+              -> pure Nothing++              |  otherwise+              -> fmap Just $ Partial.partErr sym mop $ Invalid tp'+            OldMemory off _ -> panic "Generic.writeMemWithAllocationCheck"+              [ "Unexpected offset in storage type"+              , "*** Offset:  " ++ show off+              , "*** StorageType:  " ++ show tp+              ]++          -- Given a symbolic array and an index into the array, load a byte+          -- from the corresponding position in memory and store the byte into+          -- the array at that index.+          storeArrayByteFn ::+            SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) ->+            Offset ->+            IO (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))+          storeArrayByteFn acc_arr off = do+            vc <- traverse subFn (loadBitvector off 1 0 (ValueViewVar tp))+            mb_partial_byte <- traverse (genValueCtor sym (memEndianForm mem) mop)+                                        (sequenceA vc)++            case mb_partial_byte of+              Nothing ->+                -- If we cannot load the byte from memory, skip updating the+                -- array. Currently, the only way that this can arise is when+                -- a byte of struct padding is loaded with StableSymbolic+                -- enabled.+                pure acc_arr+              Just partial_byte ->+                case partial_byte of+                  Partial.NoErr _ (LLVMValInt _ byte)+                    | Just Refl <- testEquality (knownNat @8) (bvWidth byte) -> do+                      idx <- bvAdd sym (llvmPointerOffset ptr)+                        =<< bvLit sym w (bytesToBV w off)+                      arrayUpdate sym acc_arr (Ctx.singleton idx) byte++                  Partial.NoErr _ (LLVMValZero _) -> do+                      byte <- bvLit sym knownRepr (BV.zero knownRepr)+                      idx <- bvAdd sym (llvmPointerOffset ptr)+                        =<< bvLit sym w (bytesToBV w off)+                      arrayUpdate sym acc_arr (Ctx.singleton idx) byte++                  Partial.NoErr _ v ->+                      panic "writeMemWithAllocationCheck"+                             [ "Expected byte value when updating SMT array, but got:"+                             , show v+                             ]+                  Partial.Err _ ->+                      panic "writeMemWithAllocationCheck"+                             [ "Expected succesful byte load when updating SMT array"+                             , "but got an error instead"+                             ]++      res_arr <- foldM storeArrayByteFn arr [0 .. (sz - 1)]+      overwriteArrayMem sym w ptr res_arr arr_sz mem++    _ -> return $ memAddWrite ptr (MemStore val tp alignment) mem++  return (mem', p1, p2)++-- | Overwrite SMT array.+--+-- In this case, we have generated an updated SMT array with all of+-- the changes needed to reflect this memory write.  Instead of adding+-- each individual byte write to the write log, we add a single entry that+-- shadows the entire SMT array in memory. This means that the next lookup+-- of e.g., a 4 byte read will see the updated array and be able to read 4+-- bytes from this array instead of having to traverse the write history+-- to find four different `MemStore`s.+--+-- Note that the pointer we write to is the *base* pointer (i.e., with+-- offset zero), since we are shadowing the *entire* array.+overwriteArrayMem ::+  (1 <= w, IsSymInterface sym) =>+  sym ->+  NatRepr w ->+  LLVMPtr sym w ->+  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) ->+  SymBV sym w ->+  Mem sym ->+  IO (Mem sym)+overwriteArrayMem sym w ptr arr sz mem = do+  basePtr <- LLVMPointer (llvmPointerBlock ptr) <$> bvLit sym w (BV.mkBV w 0)+  return $ memAddWrite basePtr (MemArrayStore arr (Just sz)) mem++-- | Perform a mem copy (a la @memcpy@ in C).+--+-- The returned predicates assert (in this order):+--  * the source pointer falls within an allocated memory region+--  * the dest pointer falls within an allocated, mutable memory region+copyMem ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Dest   -} ->+  LLVMPtr sym w {- ^ Source -} ->+  SymBV sym w   {- ^ Size   -} ->+  Mem sym -> IO (Mem sym, Pred sym, Pred sym)+copyMem sym w dst src sz m =+  do p1 <- isAllocated sym w noAlignment src (Just sz) m+     p2 <- isAllocatedMutable sym w noAlignment dst (Just sz) m+     dst_maybe_allocation_array <- asMemAllocationArrayStore sym w dst m+     src_maybe_allocation_array <- asMemAllocationArrayStore sym w src m+     m' <- case (dst_maybe_allocation_array, src_maybe_allocation_array) of+       -- if both the dst and src of this copy operation are inside allocations+       -- backed by SMT array stores, then replace this copy operation with+       -- using SMT array copy, and writing the result SMT array in the memory+       (Just (dst_ok, dst_arr, dst_arr_sz), Just (src_ok, src_arr, _src_arr_sz))+         | Just True <- asConstantPred dst_ok+         , Just True <- asConstantPred src_ok ->+           do res_arr <- arrayCopy sym dst_arr (llvmPointerOffset dst) src_arr (llvmPointerOffset src) sz+              overwriteArrayMem sym w dst res_arr dst_arr_sz m++       _ -> return $ memAddWrite dst (MemCopy src sz) m++     return (m', p1, p2)++-- | Perform a mem set, filling a number of bytes with a given 8-bit+-- value. The returned 'Pred' asserts that the pointer falls within an+-- allocated, mutable memory region.+setMem ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  SymBV sym 8 {- ^ Byte value -} ->+  SymBV sym w {- ^ Number of bytes to set -} ->+  Mem sym -> IO (Mem sym, Pred sym)++setMem sym w ptr val sz m =+  do p <- isAllocatedMutable sym w noAlignment ptr (Just sz) m+     maybe_allocation_array <- asMemAllocationArrayStore sym w ptr m+     m' <- case maybe_allocation_array of+       -- if this set operation is inside an allocation backed by a SMT array+       -- store, then replace this set operation with using SMT array set, and+       -- writing the result SMT array in the memory+       Just (ok, arr, arr_sz) | Just True <- asConstantPred ok ->+         do res_arr <- arraySet sym arr (llvmPointerOffset ptr) val sz+            overwriteArrayMem sym w ptr res_arr arr_sz m++       _ -> return $ memAddWrite ptr (MemSet val sz) m++     return (m', p)++writeArrayMemWithAllocationCheck ::+  (IsSymInterface sym, 1 <= w) =>+  (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) ->+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  Alignment ->+  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->+  Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} ->+  Mem sym -> IO (Mem sym, Pred sym, Pred sym)+writeArrayMemWithAllocationCheck is_allocated sym w ptr alignment arr sz m =+  do p1 <- is_allocated sym w alignment ptr sz m+     p2 <- isAligned sym w ptr alignment+     let default_m = memAddWrite ptr (MemArrayStore arr sz) m+     maybe_allocation_array <- asMemAllocationArrayStore sym w ptr m+     m' <- case maybe_allocation_array of+       -- if this write is inside an allocation backed by a SMT array store,+       -- then replace this copy operation with using SMT array copy, and+       -- writing the result SMT array in the memory+       Just (ok, alloc_arr, alloc_sz)+         | Just True <- asConstantPred ok, Just arr_sz <- sz ->+         do sz_diff <- bvSub sym alloc_sz arr_sz+            case asBV sz_diff of+              Just (BV.BV 0) -> return default_m+              _ ->+                do zero_off <- bvLit sym w $ BV.mkBV w 0+                   res_arr <- arrayCopy sym alloc_arr (llvmPointerOffset ptr) arr zero_off arr_sz+                   overwriteArrayMem sym w ptr res_arr alloc_sz m++       _ -> return default_m++     return (m', p1, p2)++-- | Write an array to memory.+--+-- The returned predicates assert (in this order):+--  * the pointer falls within an allocated, mutable memory region+--  * the pointer has the proper alignment+writeArrayMem ::+  (IsSymInterface sym, 1 <= w) =>+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  Alignment ->+  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->+  Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} ->+  Mem sym -> IO (Mem sym, Pred sym, Pred sym)+writeArrayMem = writeArrayMemWithAllocationCheck isAllocatedMutable++-- | Write an array to memory.+--+-- The returned predicates assert (in this order):+--  * the pointer falls within an allocated memory region+--  * the pointer has the proper alignment+writeArrayConstMem ::+  (IsSymInterface sym, 1 <= w) =>+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  Alignment ->+  SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} ->+  Maybe (SymBV sym w) {- ^ Array size -} ->+  Mem sym -> IO (Mem sym, Pred sym, Pred sym)+writeArrayConstMem = writeArrayMemWithAllocationCheck isAllocated++-- | Explicitly invalidate a region of memory.+invalidateMem ::+  (1 <= w, IsSymInterface sym) =>+  sym -> NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  Text          {- ^ Message -} ->+  SymBV sym w   {- ^ Number of bytes to set -} ->+  Mem sym -> IO (Mem sym, Pred sym)+invalidateMem sym w ptr msg sz m =+  do p <- isAllocatedMutable sym w noAlignment ptr (Just sz) m+     return (memAddWrite ptr (MemInvalidate msg sz) m, p)++-- | Allocate a new empty memory region.+allocMem :: (1 <= w) =>+            AllocType -- ^ Type of allocation+         -> Natural -- ^ Block id for allocation+         -> Maybe (SymBV sym w) -- ^ Size+         -> Alignment+         -> Mutability -- ^ Is block read-only+         -> String -- ^ Source location+         -> Mem sym+         -> Mem sym+allocMem a b sz alignment mut loc =+  memAddAlloc (allocMemAllocs b (AllocInfo a sz mut alignment loc))++-- | Allocate and initialize a new memory region.+allocAndWriteMem ::+  (1 <= w, IsExprBuilder sym) =>+  sym -> NatRepr w ->+  AllocType   {- ^ Type of allocation -}      ->+  Natural     {- ^ Block id for allocation -} ->+  StorageType                                 ->+  Alignment                                   ->+  Mutability  {- ^ Is block read-only -}      ->+  String      {- ^ Source location -}         ->+  LLVMVal sym {- ^ Value to write -}          ->+  Mem sym -> IO (Mem sym)+allocAndWriteMem sym w a b tp alignment mut loc v m =+  do sz <- bvLit sym w (bytesToBV w (typeEnd 0 tp))+     base <- natLit sym b+     off <- bvLit sym w (BV.zero w)+     let p = LLVMPointer base off+     return (m & allocMem a b (Just sz) alignment mut loc+               & memAddWrite p (MemStore v tp alignment))++pushStackFrameMem :: Text -> Mem sym -> Mem sym+pushStackFrameMem nm = memState %~ \s ->+  StackFrame (memStateAllocCount s) (memStateWriteCount s) nm emptyChanges s++popStackFrameMem :: forall sym. Mem sym -> Mem sym+popStackFrameMem m = m & memState %~ popf+  where popf :: MemState sym -> MemState sym+        popf (StackFrame _ _ _ (a,w) s) =+          s & memStateAddChanges c+          where c = (popMemAllocs a, w)++        -- WARNING: The following code executes a stack pop underneath a branch+        -- frame.  This is necessary to get merges to work correctly+        -- when they propagate all the way to function returns.+        -- However, it is not clear that the following code is+        -- precisely correct because it may leave in place writes to+        -- memory locations that have just been popped off the stack.+        -- This does not appear to be causing problems for our+        -- examples, but may be a source of subtle errors.+        popf (BranchFrame _ wc (a,w) s) =+          BranchFrame (sizeMemAllocs (fst c)) wc c $ popf s+          where c = (popMemAllocs a, w)++        popf EmptyMem{} = error "popStackFrameMem given unexpected memory"+++-- | Free a heap-allocated block of memory.+--+-- The returned predicates assert (in this order):+--  * the pointer points to the base of a block+--  * said block was heap-allocated, and mutable+--  * said block was not previously freed+--+-- Because the LLVM memory model allows immutable blocks to alias each other,+-- freeing an immutable block could lead to unsoundness.+freeMem :: forall sym w .+  (1 <= w, IsSymInterface sym) =>+  sym ->+  NatRepr w ->+  LLVMPtr sym w {- ^ Base of allocation to free -} ->+  Mem sym ->+  String {- ^ Source location -} ->+  IO (Mem sym, Pred sym, Pred sym, Pred sym)+freeMem sym w (LLVMPointer blk off) m loc =+  do p1 <- bvEq sym off =<< bvLit sym w (BV.zero w)+     (wasAllocated, notFreed) <- isAllocatedGeneric sym isHeapMutable blk (memAllocs m)+     return (memAddAlloc (freeMemAllocs blk loc) m, p1, wasAllocated, notFreed)+  where+    isHeapMutable :: AllocInfo sym -> IO (Pred sym)+    isHeapMutable (AllocInfo HeapAlloc _ Mutable _ _) = pure (truePred sym)+    isHeapMutable _ = pure (falsePred sym)++branchMem :: Mem sym -> Mem sym+branchMem = memState %~ \s ->+  BranchFrame (memStateAllocCount s) (memStateWriteCount s) emptyChanges s++branchAbortMem :: Mem sym -> Mem sym+branchAbortMem = memState %~ popf+  where popf (BranchFrame _ _ c s) = s & memStateAddChanges c+        popf _ = error "branchAbortMem given unexpected memory"++mergeMem :: IsExpr (SymExpr sym) => Pred sym -> Mem sym -> Mem sym -> Mem sym+mergeMem c x y =+  case (x^.memState, y^.memState) of+    (BranchFrame _ _ a s, BranchFrame _ _ b _) ->+      let s' = s & memStateAddChanges (muxChanges c a b)+      in x & memState .~ s'+    _ -> error "mergeMem given unexpected memories"++--------------------------------------------------------------------------------+-- Finding allocations++-- When we have a concrete allocation number, we can ask more specific questions+-- to the solver and get (overapproximate) concrete answers.++data SomeAlloc sym =+  forall w. (1 <= w) => SomeAlloc AllocType Natural (Maybe (SymBV sym w)) Mutability Alignment String++instance IsSymInterface sym => Eq (SomeAlloc sym) where+  SomeAlloc x_atp x_base x_sz x_mut x_alignment x_loc == SomeAlloc y_atp y_base y_sz y_mut y_alignment y_loc = do+    let sz_eq = case (x_sz, y_sz) of+          (Just x_bv, Just y_bv) -> isJust $ testEquality x_bv y_bv+          (Nothing, Nothing) -> True+          _ -> False+    x_atp == y_atp && x_base == y_base && sz_eq && x_mut == y_mut && x_alignment == y_alignment && x_loc == y_loc++ppSomeAlloc :: forall sym ann. IsExprBuilder sym => SomeAlloc sym -> Doc ann+ppSomeAlloc (SomeAlloc atp base sz mut alignment loc) =+  ppAllocInfo (base, AllocInfo atp sz mut alignment loc :: AllocInfo sym)++-- | Find an overapproximation of the set of allocations with this number.+possibleAllocs ::+  forall sym .+  (IsSymInterface sym) =>+  Natural              ->+  Mem sym              ->+  [SomeAlloc sym]+possibleAllocs n mem =+  case possibleAllocInfo n (memAllocs mem) of+    Nothing -> []+    Just (AllocInfo atp sz mut alignment loc) ->+      [SomeAlloc atp n sz mut alignment loc]++-- | Check if @LLVMPtr sym w@ points inside an allocation that is backed+--   by an SMT array store. If true, return a predicate that indicates+--   when the given array backs the given pointer, the SMT array,+--   and the size of the allocation.+--+--   NOTE: this operation is linear in the size of the list of previous+--   memory writes. This means that memory writes as well as memory reads+--   require a traversal of the list of previous writes. The performance+--   of this operation can be improved by using a map to index the writes+--   by allocation index.+asMemAllocationArrayStore ::+  forall sym w .+  (IsSymInterface sym, 1 <= w) =>+  sym ->+  NatRepr w ->+  LLVMPtr sym w {- ^ Pointer -} ->+  Mem sym ->+  IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8), (SymBV sym w)))+asMemAllocationArrayStore sym w ptr mem+  | Just blk_no <- asNat (llvmPointerBlock ptr)+  , [SomeAlloc _ _ (Just sz) _ _ _] <- List.nub (possibleAllocs blk_no mem)+  , Just Refl <- testEquality w (bvWidth sz) =+     do result <- findArrayStore blk_no sz $ memWritesAtConstant blk_no $ memWrites mem+        return $ case result of+          Just (ok, arr) -> Just (ok, arr, sz)+          Nothing -> Nothing++  | otherwise = return Nothing++ where+   findArrayStore ::+      Natural ->+      SymBV sym w ->+      [MemWrite sym] ->+      IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)))++   findArrayStore _ _ [] = return Nothing++   findArrayStore blk_no sz (head_mem_write : tail_mem_writes) =+      case head_mem_write of+         MemWrite write_ptr write_source+            | Just write_blk_no <- asNat (llvmPointerBlock write_ptr)+            , blk_no == write_blk_no+            , Just (BV.BV 0) <- asBV (llvmPointerOffset write_ptr)+            , MemArrayStore arr (Just arr_store_sz) <- write_source+            , Just Refl <- testEquality w (ptrWidth write_ptr) -> do+              ok <- bvEq sym sz arr_store_sz+              return (Just (ok, arr))++            | Just write_blk_no <- asNat (llvmPointerBlock write_ptr)+            , blk_no /= write_blk_no ->+              findArrayStore blk_no sz tail_mem_writes++            | otherwise -> return Nothing++         WriteMerge cond lhs_mem_writes rhs_mem_writes -> do+            lhs_result <- findArrayStore blk_no sz (memWritesAtConstant blk_no lhs_mem_writes)+            rhs_result <- findArrayStore blk_no sz (memWritesAtConstant blk_no rhs_mem_writes)++            -- Only traverse the tail if necessary, and be careful+            -- only to traverse it once+            case (lhs_result, rhs_result) of+              (Just _, Just _) -> combineResults cond lhs_result rhs_result++              (Just _, Nothing) ->+                do rhs' <- findArrayStore blk_no sz tail_mem_writes+                   combineResults cond lhs_result rhs'++              (Nothing, Just _) ->+                do lhs' <- findArrayStore blk_no sz tail_mem_writes+                   combineResults cond lhs' rhs_result++              (Nothing, Nothing) -> findArrayStore blk_no sz tail_mem_writes++   combineResults cond (Just (lhs_ok, lhs_arr)) (Just (rhs_ok, rhs_arr)) =+      do ok <- itePred sym cond lhs_ok rhs_ok+         arr <- arrayIte sym cond lhs_arr rhs_arr+         pure (Just (ok,arr))++   combineResults cond (Just (lhs_ok, lhs_arr)) Nothing =+      do ok <- andPred sym cond lhs_ok+         pure (Just (ok, lhs_arr))++   combineResults cond Nothing (Just (rhs_ok, rhs_arr)) =+      do cond' <- notPred sym cond+         ok <- andPred sym cond' rhs_ok+         pure (Just (ok, rhs_arr))++   combineResults _cond Nothing Nothing = pure Nothing++{- Note [Memory Model Design]++At a high level, the memory model is represented as a list of memory writes+(with embedded muxes).  Reads from the memory model are accomplished by+1. Traversing backwards in the write log until the most recent write to each byte+   needed to satisfy the read has been covered by a write+2. Re-assembling the read value from fragments of those writes++This story is slightly complicated by optimizations and the fact that memory+regions can be represented in two different ways:+- "plain" allocations that are represented as symbolic bytes managed explicitly by the memory model, and+- Symbolic array storage backed by SMT arrays++The former allow for significant optimizations that lead to smaller formulas for+the underlying SMT solver.  The latter support symbolic reads efficiently.  The+former also supports symbolic reads, at the cost of extremely expensive and+large muxes.++* Memory Writes++The entry point for writing values to memory is 'writeMem' (which is just a+wrapper around 'writeMemWithAllocationCheck').  Writing a value to memory is+relatively simple, with only two major cases to consider.++The first case is an optimization over the SMT array backed memory model.  In+this case, the write can be statically determined to be contained entirely+within the bounds of an SMT array.  For efficiency, the memory model employs an+optimization that generates an updated SMT array (via applications of the SMT+`update` operator) and adds a special entry in the write log that shadows the+entire address range covered by that array in the write history (effectively+overwriting the entire backing array).  The goal of this optimization is to+reduce the number of muxes generated in subsequent reads.++In the general case, writing to the memory model adds a write record to the+write log.++* Memory Reads++The entry point for reading is the 'readMem' function.  Reading is more+complicated than writing, as reads can span multiple writes (and also multiple+different allocation types).++The memory reading code has an optimization to match the 'writeMem' case: if a+read is fully-covered by an SMT array, a fast path is taken that generates small+concrete array select terms.++In the fallback case, 'readMem' (via 'readMem'') traverses the write log to+assemble a Part(ial)LLVMVal from multiple writes.  The code is somewhat CPSed+via the 'readPrev' functions in that code.  If the traversal of the write log+finds a write that provides some, but not all, of the bytes covering a read, it+saves those bytes and invokes 'readPrev' to step back through the write log.+See Note [Value Reconstruction] for a description of how bytes from multiple+writes are re-assembled.  Note that the write log is a mix of 'MemWrite's and+'WriteMerge's; the explicit merge markers turn the log into a tree, where the+join points create muxes in the read value.++Note that the partiality in 'Part(ial)LLVMVal's does not refer to fragments of+values.  Instead, it refers to the fact that values may be only defined when+some predicate is true.++* Special Operations++The memory model has special support for memcpy and memset operations, which are+able to support symbolic lengths.  These operations are represented as+distinguished operations in the write log and are incorporated into the results+of reads as appropriate.++-}+++{- Note [Value Reconstruction]++When a value is read, it may span multiple writes in memory (as C/C++/machine+code can do all manner of partial writes into the middle of objects).  The+various reading operations thus produce values of type 'ValueCtor' to represent+the reconstruction of values from fragments.  The 'ValueCtor' is essentially a+script in a restricted DSL that reconstructs values.  The "script" is+interpreted by 'genValueCtor'.++The reconstruction scripts are produced by the 'valueLoad', 'symbolicValueLoad',+and 'rangeLoad' functions.  Note that 'rangeLoad' is used for allocations backed+by SMT arrays, and thus always supports symbolic loads. These functions handle+the complexities of handling padding and data type interpretations.  The fast+paths in the read functions are able to call these directly (i.e., when offsets+and sizes are concrete).++-}
+ src/Lang/Crucible/LLVM/MemModel/MemLog.hs view
@@ -0,0 +1,746 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.MemLog+-- Description      : Data types supporting the LLVM memory model+-- Copyright        : (c) Galois, Inc 2011-2020+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# Language ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-}++module Lang.Crucible.LLVM.MemModel.MemLog+  (+    -- * Allocation logs+    AllocType(..)+  , Mutability(..)+  , AllocInfo(..)+  , MemAllocs(..)+  , MemAlloc(..)+  , sizeMemAllocs+  , allocMemAllocs+  , freeMemAllocs+  , muxMemAllocs+  , popMemAllocs+  , possibleAllocInfo+  , isAllocatedGeneric+    -- * Write logs+  , WriteSource(..)+  , MemWrite(..)+  , MemWrites(..)+  , MemWritesChunk(..)+  , memWritesSingleton+    -- * Memory logs+  , MemState(..)+  , MemChanges+  , memState+  , Mem(..)+  , emptyChanges+  , emptyMem+  , memEndian++    -- * Pretty printing+  , ppType+  , ppPtr+  , ppAllocInfo+  , ppAllocs+  , ppMem+  , ppMemWrites+  , ppWrite++    -- * Write ranges+  , writeRangesMem++    -- * Concretization+  , concPtr+  , concLLVMVal+  , concMem+  ) where++import           Control.Applicative ((<|>))+import           Control.Lens+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Data.Foldable+import           Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List.Extra as List+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Maybe (mapMaybe)+import           Data.Text (Text)+import           Numeric.Natural+import           Prettyprinter++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Ctx (SingleCtx)++import           What4.Interface+import           What4.Expr (GroundValue)++import           Lang.Crucible.LLVM.DataLayout (Alignment, fromAlignment, EndianForm(..))+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemModel.Type+import           Lang.Crucible.LLVM.MemModel.Value++--------------------------------------------------------------------------------+-- Allocations++data AllocType = StackAlloc | HeapAlloc | GlobalAlloc+  deriving (Eq, Ord, Show)++data Mutability = Mutable | Immutable+  deriving (Eq, Ord, Show)++-- | Details of a single allocation. The @Maybe SymBV@ argument is either a+-- size or @Nothing@ representing an unbounded allocation. The 'Mutability'+-- indicates whether the region is read-only. The 'String' contains source+-- location information for use in error messages.+data AllocInfo sym =+  forall w. (1 <= w) => AllocInfo AllocType (Maybe (SymBV sym w)) Mutability Alignment String++-- | Stores writeable memory allocations.+data MemAlloc sym+    -- | A collection of consecutive basic allocations.+  = Allocations (Map Natural (AllocInfo sym))+    -- | Freeing of the given block ID.+  | MemFree (SymNat sym) String+    -- | The merger of two allocations.+  | AllocMerge (Pred sym) (MemAllocs sym) (MemAllocs sym)++-- | A record of which memory regions have been allocated or freed.++-- Memory allocations are represented as a list with the invariant+-- that any two adjacent 'Allocations' constructors must be merged+-- together, and that no 'Allocations' constructor has an empty map.+newtype MemAllocs sym = MemAllocs [MemAlloc sym]++instance Semigroup (MemAllocs sym) where+  (MemAllocs lhs_allocs) <> (MemAllocs rhs_allocs)+    | Just (lhs_head_allocs, Allocations lhs_m) <- List.unsnoc lhs_allocs+    , Allocations rhs_m : rhs_tail_allocs <- rhs_allocs+    = MemAllocs (lhs_head_allocs ++ [Allocations (Map.union lhs_m rhs_m)] ++ rhs_tail_allocs)+    | otherwise = MemAllocs (lhs_allocs ++ rhs_allocs)++instance Monoid (MemAllocs sym) where+  mempty = MemAllocs []+++sizeMemAlloc :: MemAlloc sym -> Int+sizeMemAlloc =+  \case+    Allocations m -> Map.size m+    MemFree{} -> 1+    AllocMerge{} -> 1++-- | Compute the size of a 'MemAllocs' log.+sizeMemAllocs :: MemAllocs sym -> Int+sizeMemAllocs (MemAllocs allocs) = sum (map sizeMemAlloc allocs)++-- | Returns true if this consists of a empty collection of memory allocs.+nullMemAllocs :: MemAllocs sym -> Bool+nullMemAllocs (MemAllocs xs) = null xs++-- | Allocate a new block with the given allocation ID.+allocMemAllocs :: Natural -> AllocInfo sym -> MemAllocs sym -> MemAllocs sym+allocMemAllocs blk info ma = MemAllocs [Allocations (Map.singleton blk info)] <> ma++-- | Free the block with the given allocation ID.+freeMemAllocs :: SymNat sym -> String {- ^ Location info for debugging -} -> MemAllocs sym -> MemAllocs sym+freeMemAllocs blk loc (MemAllocs xs) = MemAllocs (MemFree blk loc : xs)++muxMemAllocs :: IsExpr (SymExpr sym) => Pred sym -> MemAllocs sym -> MemAllocs sym -> MemAllocs sym+muxMemAllocs _ (MemAllocs []) (MemAllocs []) = MemAllocs []+muxMemAllocs c xs ys =+  case asConstantPred c of+    Just True -> xs+    Just False -> ys+    Nothing -> MemAllocs [AllocMerge c xs ys]++-- | Purge all stack allocations from the allocation log.+popMemAllocs :: forall sym. MemAllocs sym -> MemAllocs sym+popMemAllocs (MemAllocs xs) = MemAllocs (mapMaybe popMemAlloc xs)+  where+    popMemAlloc :: MemAlloc sym -> Maybe (MemAlloc sym)+    popMemAlloc (Allocations am) =+      if Map.null am' then Nothing else Just (Allocations am')+      where am' = Map.filter notStackAlloc am+    popMemAlloc a@(MemFree _ _) = Just a+    popMemAlloc (AllocMerge c x y) = Just (AllocMerge c (popMemAllocs x) (popMemAllocs y))++    notStackAlloc :: AllocInfo sym -> Bool+    notStackAlloc (AllocInfo x _ _ _ _) = x /= StackAlloc++-- | Look up the 'AllocInfo' for the given allocation number. A 'Just'+-- result indicates that the specified memory region may or may not+-- still be allocated; 'Nothing' indicates that the memory region is+-- definitely not allocated.+possibleAllocInfo ::+  forall sym.+  IsExpr (SymExpr sym) =>+  Natural ->+  MemAllocs sym ->+  Maybe (AllocInfo sym)+possibleAllocInfo n (MemAllocs xs) = asum (map helper xs)+  where+    helper :: MemAlloc sym -> Maybe (AllocInfo sym)+    helper =+      \case+        MemFree _ _ -> Nothing+        Allocations m -> Map.lookup n m+        AllocMerge cond ma1 ma2 ->+          case asConstantPred cond of+            Just True -> possibleAllocInfo n ma1+            Just False -> possibleAllocInfo n ma2+            Nothing -> possibleAllocInfo n ma1 <|> possibleAllocInfo n ma2+++-- | Generalized function for checking whether a memory region ID is allocated.+--+-- The first predicate indicates whether the region was allocated, the second+-- indicates whether it has *not* been freed.+isAllocatedGeneric ::+  forall sym.+  (IsExpr (SymExpr sym), IsExprBuilder sym) =>+  sym ->+  (AllocInfo sym -> IO (Pred sym)) ->+  SymNat sym ->+  MemAllocs sym ->+  IO (Pred sym, Pred sym)+isAllocatedGeneric sym inAlloc blk = go (pure (falsePred sym)) (pure (truePred sym))+  where+    go :: IO (Pred sym) -> IO (Pred sym) -> MemAllocs sym -> IO (Pred sym, Pred sym)+    go fallback fallbackFreed (MemAllocs []) = (,) <$> fallback <*> fallbackFreed+    go fallback fallbackFreed (MemAllocs (alloc : r)) =+      case alloc of+        Allocations am ->+          case asNat blk of+            Just b -> -- concrete block number, look up entry+              case Map.lookup b am of+                Nothing -> go fallback fallbackFreed (MemAllocs r)+                Just ba -> (,) <$> inAlloc ba <*> fallbackFreed+            Nothing -> -- symbolic block number, need to check all entries+              Map.foldrWithKey checkEntry (go fallback fallbackFreed (MemAllocs r)) am+              where+                checkEntry a ba k =+                  do+                     sameBlock <- natEq sym blk =<< natLit sym a+                     case asConstantPred sameBlock of+                       Just True ->+                         -- This is where where this block was allocated, and it+                         -- couldn't have been freed before it was allocated.+                         --+                         -- NOTE(lb): It's not clear to me that this branch is+                         -- reachable: If the equality test can succeed+                         -- concretely, wouldn't asNat have returned a Just+                         -- above? In either case, this answer should be sound.+                         return (truePred sym, truePred sym)+                       Just False -> k+                       Nothing ->+                         do (fallback', fallbackFreed') <- k+                            here <- itePredM sym sameBlock (inAlloc ba) (pure fallback')+                            pure (here, fallbackFreed')+        MemFree a _ ->+          do sameBlock <- natEq sym blk a+             case asConstantPred sameBlock of+               Just True  ->+                 -- If it was freed, it also must have been allocated beforehand.+                 return (truePred sym, falsePred sym)+               Just False -> go fallback fallbackFreed (MemAllocs r)+               Nothing    ->+                 do (inRest, notFreedInRest) <-+                      go fallback fallbackFreed (MemAllocs r)+                    notSameBlock <- notPred sym sameBlock+                    (inRest,) <$> andPred sym notSameBlock notFreedInRest+        AllocMerge _ (MemAllocs []) (MemAllocs []) ->+          go fallback fallbackFreed (MemAllocs r)+        AllocMerge c xr yr ->+          do (inRest, notFreedInRest) <- go fallback fallbackFreed (MemAllocs r) -- TODO: wrap this in a delay+             (inTrue, notFreedInTrue) <- go (pure inRest) (pure notFreedInRest) xr+             (inFalse, notFreedInFalse) <- go (pure inRest) (pure notFreedInRest) yr+             (,) <$> itePred sym c inTrue inFalse+                 <*> itePred sym c notFreedInTrue notFreedInFalse++--------------------------------------------------------------------------------+-- Writes++data WriteSource sym w+    -- | @MemCopy src len@ copies @len@ bytes from [src..src+len).+  = MemCopy (LLVMPtr sym w) (SymBV sym w)+    -- | @MemSet val len@ fills the destination with @len@ copies of byte @val@.+  | MemSet (SymBV sym 8) (SymBV sym w)+    -- | @MemStore val ty al@ writes value @val@ with type @ty@ at the destination.+    --   with alignment at least @al@.+  | MemStore (LLVMVal sym) StorageType Alignment+    -- | @MemArrayStore block (Just len)@ writes byte-array @block@ of size+    -- @len@ at the destination; @MemArrayStore block Nothing@ writes byte-array+    -- @block@ of unbounded size+  | MemArrayStore (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)) (Maybe (SymBV sym w))+    -- | @MemInvalidate len@ flags @len@ bytes as uninitialized.+  | MemInvalidate Text (SymBV sym w)++data MemWrite sym+    -- | @MemWrite dst src@ represents a write to @dst@ from the given source.+  = forall w. (1 <= w) => MemWrite (LLVMPtr sym w) (WriteSource sym w)+    -- | The merger of two memories.+  | WriteMerge (Pred sym) (MemWrites sym) (MemWrites sym)+++--------------------------------------------------------------------------------+-- Memory++-- | A symbolic representation of the LLVM heap.+--+-- This representation is designed to support a variety of operations+-- including reads and writes of symbolic data to symbolic addresses,+-- symbolic memcpy and memset, and merging two memories in a single+-- memory using an if-then-else operation.+--+-- A common use case is that the symbolic simulator will branch into+-- two execution states based on a symbolic branch, make different+-- memory modifications on each branch, and then need to merge the two+-- memories to resume execution along a single path using the branch+-- condition.  To support this, our memory representation supports+-- "branch frames", at any point one can insert a fresh branch frame+-- (see `branchMem`), and then at some later point merge two memories+-- back into a single memory (see `mergeMem`).  Our `mergeMem`+-- implementation is able to efficiently merge memories, but requires+-- that one only merge memories that were identical prior to the last+-- branch.+data Mem sym = Mem { memEndianForm :: EndianForm, _memState :: MemState sym }++memState :: Lens' (Mem sym) (MemState sym)+memState = lens _memState (\s v -> s { _memState = v })++-- | A state of memory as of a stack push, branch, or merge.  Counts+-- of the total number of allocations and writes are kept for+-- performance metrics.+data MemState sym =+    -- | Represents initial memory and changes since then.+    -- Changes are stored in order, with more recent changes closer to the head+    -- of the list.+    EmptyMem !Int !Int (MemChanges sym)+    -- | Represents a push of a stack frame, and changes since that stack push.+    -- The text value gives a user-consumable name for the stack frame.+    -- Changes are stored in order, with more recent changes closer to the head+    -- of the list.+  | StackFrame !Int !Int Text (MemChanges sym) (MemState sym)+    -- | Represents a push of a branch frame, and changes since that branch.+    -- Changes are stored in order, with more recent changes closer to the head+    -- of the list.+  | BranchFrame !Int !Int (MemChanges sym) (MemState sym)++type MemChanges sym = (MemAllocs sym, MemWrites sym)++-- | Memory writes are represented as a list of chunks of writes.+--   Chunks alternate between being indexed and being flat.+newtype MemWrites sym = MemWrites [MemWritesChunk sym]++-- | Returns true if this consists of a empty collection of memory writes+nullMemWrites :: MemWrites sym -> Bool+nullMemWrites (MemWrites ws) = null ws++-- | A chunk of memory writes is either indexed or flat (unindexed).+--   An indexed chunk consists of writes to addresses with concrete+--   base pointers and is represented as a map. A flat chunk consists of+--   writes to addresses with symbolic base pointers. A merge of two+--   indexed chunks is a indexed chunk, while any other merge is part of+--   a flat chunk.+data MemWritesChunk sym =+    MemWritesChunkFlat [MemWrite sym]+  | MemWritesChunkIndexed (IntMap [MemWrite sym])++instance Semigroup (MemWrites sym) where+  (MemWrites lhs_writes) <> (MemWrites rhs_writes)+    | Just (lhs_head_writes, lhs_tail_write) <- List.unsnoc lhs_writes+    , MemWritesChunkIndexed lhs_tail_indexed_writes <- lhs_tail_write+    , rhs_head_write : rhs_tail_writes <- rhs_writes+    , (MemWritesChunkIndexed rhs_head_indexed_writes) <- rhs_head_write = do+      let merged_chunk = MemWritesChunkIndexed $ IntMap.mergeWithKey+            (\_ lhs_alloc_writes rhs_alloc_writes ->+              Just $ lhs_alloc_writes ++ rhs_alloc_writes)+            id+            id+            lhs_tail_indexed_writes+            rhs_head_indexed_writes+      MemWrites $ lhs_head_writes ++ [merged_chunk] ++ rhs_tail_writes+    | otherwise = MemWrites $ lhs_writes ++ rhs_writes++instance Monoid (MemWrites sym) where+  mempty = MemWrites []+++memWritesSingleton ::+  (IsExprBuilder sym, 1 <= w) =>+  LLVMPtr sym w ->+  WriteSource sym w ->+  MemWrites sym+memWritesSingleton ptr src+  | Just blk <- asNat (llvmPointerBlock ptr)+  , isIndexableSource src =+    MemWrites+      [ MemWritesChunkIndexed $+          IntMap.singleton (fromIntegral blk) [MemWrite ptr src]+      ]+  | otherwise = MemWrites [MemWritesChunkFlat [MemWrite ptr src]]+  where+    isIndexableSource ::  WriteSource sym w -> Bool+    isIndexableSource = \case+      MemStore{} -> True+      MemArrayStore{} -> True+      MemSet{} -> True+      MemInvalidate{} -> True+      MemCopy{} -> False++++emptyChanges :: MemChanges sym+emptyChanges = (mempty, mempty)++emptyMem :: EndianForm -> Mem sym+emptyMem e = Mem { memEndianForm = e, _memState = EmptyMem 0 0 emptyChanges }++memEndian :: Mem sym -> EndianForm+memEndian = memEndianForm+++--------------------------------------------------------------------------------+-- Pretty printing++ppMerge :: IsExpr e+        => (v -> Doc ann)+        -> e tp+        -> [v]+        -> [v]+        -> Doc ann+ppMerge vpp c x y =+  indent 2 $+  vcat+  [ "Condition:"+  , indent 2 (printSymExpr c)+  , ppAllocList x "True Branch:"+  , ppAllocList y "False Branch:"+  ]+  where ppAllocList [] d = d <+> "<none>"+        ppAllocList xs d = vcat [d, indent 2 (vcat $ map vpp xs)]++ppAlignment :: Alignment -> Doc ann+ppAlignment a =+  pretty $ show (fromAlignment a) ++ "-byte-aligned"++ppAllocInfo :: IsExpr (SymExpr sym) => (Natural, AllocInfo sym) -> Doc ann+ppAllocInfo (base, AllocInfo atp sz mut alignment loc) =+  viaShow atp+  <+> pretty base+  <+> maybe mempty printSymExpr sz+  <+> viaShow mut+  <+> ppAlignment alignment+  <+> pretty loc++ppAlloc :: IsExpr (SymExpr sym) => MemAlloc sym -> Doc ann+ppAlloc (Allocations xs) =+  vcat $ map ppAllocInfo (reverse (Map.assocs xs))+ppAlloc (MemFree base loc) =+  "Free" <+> printSymNat base <+> pretty loc+ppAlloc (AllocMerge c (MemAllocs x) (MemAllocs y)) =+  vcat ["Merge", ppMerge ppAlloc c x y]++ppAllocs :: IsExpr (SymExpr sym) => MemAllocs sym -> Doc ann+ppAllocs (MemAllocs xs) = vcat $ map ppAlloc xs++ppWrite :: IsExpr (SymExpr sym) => MemWrite sym -> Doc ann+ppWrite (MemWrite d (MemCopy s l)) = do+  "memcopy" <+> ppPtr d <+> ppPtr s <+> printSymExpr l+ppWrite (MemWrite d (MemSet v l)) = do+  "memset" <+> ppPtr d <+> printSymExpr v <+> printSymExpr l+ppWrite (MemWrite d (MemStore v _ _)) = do+  pretty '*' <> ppPtr d <+> ":=" <+> ppTermExpr v+ppWrite (MemWrite d (MemArrayStore arr _)) = do+  pretty '*' <> ppPtr d <+> ":=" <+> printSymExpr arr+ppWrite (MemWrite d (MemInvalidate msg l)) = do+  "invalidate" <+> parens (pretty msg) <+> ppPtr d <+> printSymExpr l+ppWrite (WriteMerge c (MemWrites x) (MemWrites y)) = do+  vcat ["merge", ppMerge ppMemWritesChunk c x y]++ppMemWritesChunk :: IsExpr (SymExpr sym) => MemWritesChunk sym -> Doc ann+ppMemWritesChunk = \case+  MemWritesChunkFlat [] ->+    "No writes"+  MemWritesChunkFlat flat_writes ->+    vcat $ map ppWrite flat_writes+  MemWritesChunkIndexed indexed_writes ->+    vcat+    [ "Indexed chunk:"+    , indent 2 (vcat $ map+        (\(blk, blk_writes) ->+          case blk_writes of+            [] -> mempty+            _  -> viaShow blk <+> "|->" <> softline <>+                    indent 2 (vcat $ map ppWrite blk_writes))+        (IntMap.toList indexed_writes))+    ]++ppMemWrites :: IsExpr (SymExpr sym) => MemWrites sym -> Doc ann+ppMemWrites (MemWrites ws) = vcat $ map ppMemWritesChunk ws++ppMemChanges :: IsExpr (SymExpr sym) => MemChanges sym -> [Doc ann]+ppMemChanges (al,wl)+  | nullMemAllocs al && nullMemWrites wl = ["No writes or allocations"]+  | otherwise =+      (if nullMemAllocs al then [] else ["Allocations:", indent 2 (ppAllocs al)]) <>+      (if nullMemWrites wl then [] else ["Writes:", indent 2 (ppMemWrites wl)])++ppMemState :: (MemChanges sym -> [Doc ann]) -> MemState sym -> Doc ann+ppMemState f (EmptyMem _ _ d) =+  vcat ("Base memory" : map (indent 2) (f d))+ppMemState f (StackFrame _ _ nm d ms) =+  vcat (("Stack frame" <+> pretty nm) : map (indent 2) (f d) ++ [ppMemState f ms])+ppMemState f (BranchFrame _ _ d ms) =+  vcat ("Branch frame" : map (indent 2) (f d) ++ [ppMemState f ms])++ppMem :: IsExpr (SymExpr sym) => Mem sym -> Doc ann+ppMem m = ppMemState ppMemChanges (m^.memState)+++------------------------------------------------------------------------------+-- Write ranges++multiUnion :: (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a+multiUnion = Map.unionWith (<>)++writeSourceSize ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  WriteSource sym w ->+  MaybeT IO (SymBV sym w)+writeSourceSize sym = \case+  MemCopy _src sz -> pure sz+  MemSet _val sz -> pure sz+  MemStore _val st _align ->+    liftIO $ bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth $ toInteger $ typeEnd 0 st+  MemArrayStore _arr Nothing -> MaybeT $ pure Nothing+  MemArrayStore _arr (Just sz) -> pure sz+  MemInvalidate _nm sz -> pure sz++writeRangesMemWrite ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  MemWrite sym ->+  MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)])+writeRangesMemWrite sym = \case+  MemWrite ptr wsrc+    | Just Refl <- testEquality ?ptrWidth (ptrWidth ptr) ->+      case asNat (llvmPointerBlock ptr) of+        Just blk -> do+          sz <- writeSourceSize sym wsrc+          pure $ Map.singleton blk [(llvmPointerOffset ptr, sz)]+        Nothing -> MaybeT $ pure Nothing+    | otherwise -> fail "foo"+  WriteMerge _p ws1 ws2 ->+    multiUnion <$> writeRangesMemWrites sym ws1 <*> writeRangesMemWrites sym ws2++writeRangesMemWritesChunk ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  MemWritesChunk sym ->+  MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)])+writeRangesMemWritesChunk sym = \case+  MemWritesChunkFlat ws -> foldl multiUnion Map.empty <$> mapM (writeRangesMemWrite sym) ws+  MemWritesChunkIndexed mp ->+    foldl multiUnion Map.empty <$> mapM (writeRangesMemWrite sym) (concat $ IntMap.elems mp)++writeRangesMemWrites ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  MemWrites sym ->+  MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)])+writeRangesMemWrites sym (MemWrites ws) =+  foldl multiUnion Map.empty <$> mapM (writeRangesMemWritesChunk sym) ws++writeRangesMemChanges ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  MemChanges sym ->+  MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)])+writeRangesMemChanges sym (_as, ws) = writeRangesMemWrites sym ws++writeRangesMemState ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  MemState sym ->+  MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)])+writeRangesMemState sym = \case+  EmptyMem _a _w chs -> writeRangesMemChanges sym chs+  StackFrame _a _w _nm chs st ->+    multiUnion <$> writeRangesMemChanges sym chs <*> writeRangesMemState sym st+  BranchFrame _a _w chs st ->+    multiUnion <$> writeRangesMemChanges sym chs <*> writeRangesMemState sym st++-- | Compute the ranges (pairs of the form pointer offset and size) for all+-- memory writes, indexed by the pointer base. The result is Nothing if the+-- memory contains any writes with symbolic pointer base, or without size.+writeRangesMem ::+  (IsExprBuilder sym, HasPtrWidth w) =>+  sym ->+  Mem sym ->+  MaybeT IO ((Map Natural [(SymBV sym w, SymBV sym w)]))+writeRangesMem sym mem = writeRangesMemState sym $ mem ^. memState+++------------------------------------------------------------------------------+-- Concretization++concAllocInfo ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  AllocInfo sym -> IO (AllocInfo sym)+concAllocInfo sym conc (AllocInfo atp sz m a nm) =+  do sz' <- traverse (concBV sym conc) sz+     pure (AllocInfo atp sz' m a nm)++concAlloc ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemAlloc sym -> IO (MemAllocs sym)+concAlloc sym conc (Allocations m) =+  do m' <- traverse (concAllocInfo sym conc) m+     pure (MemAllocs [Allocations m'])+concAlloc sym conc (MemFree blk loc) =+  do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk+     pure (MemAllocs [MemFree blk' loc])+concAlloc sym conc (AllocMerge p m1 m2) =+  do b <- conc p+     if b then concMemAllocs sym conc m1+          else concMemAllocs sym conc m2++concMemAllocs ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemAllocs sym -> IO (MemAllocs sym)+concMemAllocs sym conc (MemAllocs cs) =+  fold <$> traverse (concAlloc sym conc) cs++concLLVMVal ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  LLVMVal sym -> IO (LLVMVal sym)+concLLVMVal sym conc (LLVMValInt blk off) =+  do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk+     off' <- concBV sym conc off+     pure (LLVMValInt blk' off')+concLLVMVal _sym _conc (LLVMValFloat fs fi) =+  pure (LLVMValFloat fs fi) -- TODO concreteize floats+concLLVMVal sym conc (LLVMValStruct fs) =+  LLVMValStruct <$> traverse (\ (fi,v) -> (,) <$> pure fi <*> concLLVMVal sym conc v) fs+concLLVMVal sym conc (LLVMValArray st vs) =+  LLVMValArray st <$> traverse (concLLVMVal sym conc) vs+concLLVMVal _ _ v@LLVMValString{} = pure v+concLLVMVal _ _ v@LLVMValZero{} = pure v+concLLVMVal _ _ (LLVMValUndef st) =+  pure (LLVMValZero st) -- ??? does it make sense to turn Undef into Zero?+++concWriteSource ::+  (IsExprBuilder sym, 1 <= w) =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  WriteSource sym w -> IO (WriteSource sym w)+concWriteSource sym conc (MemCopy src len) =+  MemCopy <$> (concPtr sym conc src) <*> (concBV sym conc len)+concWriteSource sym conc (MemSet val len) =+  MemSet <$> (concBV sym conc val) <*> (concBV sym conc len)+concWriteSource sym conc (MemStore val st a) =+  MemStore <$> concLLVMVal sym conc val <*> pure st <*> pure a++concWriteSource _sym _conc (MemArrayStore arr Nothing) =+  -- TODO, concretize the actual array+  pure (MemArrayStore arr Nothing)+concWriteSource sym conc (MemArrayStore arr (Just sz)) =+  -- TODO, concretize the actual array+  MemArrayStore arr . Just <$> concBV sym conc sz++concWriteSource sym conc (MemInvalidate nm len) =+  MemInvalidate nm <$> concBV sym conc len++concMemWrite ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemWrite sym -> IO (MemWrites sym)+concMemWrite sym conc (MemWrite ptr wsrc) =+  do ptr' <- concPtr sym conc ptr+     wsrc' <- concWriteSource sym conc wsrc+     pure $ memWritesSingleton ptr' wsrc'+concMemWrite sym conc (WriteMerge p m1 m2) =+  do b <- conc p+     if b then concMemWrites sym conc m1+          else concMemWrites sym conc m2++concMemWrites ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemWrites sym -> IO (MemWrites sym)+concMemWrites sym conc (MemWrites cs) =+  fold <$> mapM (concMemWritesChunk sym conc) cs++concMemWritesChunk ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemWritesChunk sym -> IO (MemWrites sym)+concMemWritesChunk sym conc (MemWritesChunkFlat ws) =+  fold <$> mapM (concMemWrite sym conc) ws+concMemWritesChunk sym conc (MemWritesChunkIndexed mp) =+  fold <$> mapM (concMemWrite sym conc) (concat (IntMap.elems mp))++concMemChanges ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemChanges sym -> IO (MemChanges sym)+concMemChanges sym conc (as, ws) =+  (,) <$> concMemAllocs sym conc as <*> concMemWrites sym conc ws+++concMemState ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  MemState sym -> IO (MemState sym)+concMemState sym conc (EmptyMem a w chs) =+  EmptyMem a w <$> concMemChanges sym conc chs+concMemState sym conc (StackFrame a w nm frm stk) =+  StackFrame a w nm <$> concMemChanges sym conc frm <*> concMemState sym conc stk+concMemState sym conc (BranchFrame a w frm stk) =+  BranchFrame a w <$> concMemChanges sym conc frm <*> concMemState sym conc stk++concMem ::+  IsExprBuilder sym =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  Mem sym -> IO (Mem sym)+concMem sym conc (Mem endian st) =+  Mem endian <$> concMemState sym conc st
+ src/Lang/Crucible/LLVM/MemModel/Options.hs view
@@ -0,0 +1,128 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Options+-- Description      : Definition of options that can be tweaked in the memory model+-- Copyright        : (c) Galois, Inc 2019+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++module Lang.Crucible.LLVM.MemModel.Options+  ( MemOptions(..)+  , IndeterminateLoadBehavior(..)+  , defaultMemOptions+  , laxPointerMemOptions+  ) where++-- | This datatype encodes a variety of tweakable settings supported+--   by the LLVM memory model.  They generally involve some weakening+--   of the strict rules of the language standard to allow common+--   idioms, at the cost that reasoning using the resulting memory model+--   is less generalizable (i.e., makes more assumptions about the+--   runtime behavior of the system).+data MemOptions+  = MemOptions+    { laxPointerOrdering :: !Bool+      -- ^ Should we allow ordering comparisons on pointers that are+      --   not from the same allocation unit?  This is not allowed+      --   by the C standard, but is nonetheless commonly done.++    , laxConstantEquality :: !Bool+      -- ^ Should we allow equality comparisons on pointers to constant+      --   data? Different symbols with the same data are allowed to+      --   be consolidated, so pointer apparently-distinct pointers+      --   will sometimes compare equal if the compiler decides to+      --   consolidate their storage.++    , laxLoadsAndStores :: !Bool+      -- ^ Should we relax some of Crucible's validity checks for memory loads+      --   and stores? If 'True', the following checks will be relaxed:+      --+      --   * Reading from previously unwritten memory will succeed rather than+      --     throwing a 'NoSatisfyingWrite' error. The semantics of what it+      --     means to read from uninitialized memory is controlled separately+      --     by the 'indeterminateLoadBehavior' option.+      --+      --   * If reading from a region that isn't allocated or isn't large+      --     enough, Crucible will proceed rather than throw an+      --     'UnreadableRegion' error.+      --+      --   * Reading a value from a pointer with insufficent alignment is not+      --     treated as undefined behavior. That is, Crucible will not throw a+      --     'ReadBadAlignment' error.+      --+      --   * Adding an offset to a pointer that results in a pointer to an+      --     address outside of the allocation is not treated as undefined+      --     behavior. That is, Crucible will not throw a+      --     'PtrAddOffsetOutOfBounds' error.+      --+      --   This option is primarily useful for SV-COMP, which does not treat+      --   the scenarios listed above as fatal errors.++    , indeterminateLoadBehavior :: IndeterminateLoadBehavior+      -- ^ If 'laxLoadsAndStores' is enabled, what should be the semantics of+      --   reading from uninitialized memory? See the Haddocks for+      --   'IndeterminateLoadBehavior' for an explanation of each possible+      --   semantics.+      --+      --   If 'laxLoadsAndStores' is disabled, this option has no effect.+    }+++-- | What should be the semantics of reading from previously uninitialized+--   memory?+data IndeterminateLoadBehavior+  = StableSymbolic+    -- ^ After allocating memory (be it through @alloca@, @malloc@, @calloc@,+    --   or a similar function), initialize it with a fresh symbolic value of+    --   the corresponding type. As a result, reading from \"uninitialized\"+    --   memory will always succeed, as uninitialized memory will contain+    --   symbolic data if it has not yet been written to. This is \"stable\"+    --   in the sense that reading from the same section of uninitialized+    --   memory multiple times will always yield the same symbolic value.+    --+    --   This is primarily useful for SV-COMP, as these semantics closely align+    --   with SV-COMP's expectations.++  | UnstableSymbolic+    -- ^ Each read from a section of uninitialized memory will return a fresh+    --   symbolic value of the corresponding type. The operative word is+    --   \"fresh\", as each of these symbolic values will be considered+    --   distinct. That is, the symbolic values are \"unstable\". Contrast this+    --   with 'StableSymbolic', in which multiple reads from the same section+    --   of uninitialized memory will all yield the same symbolic value.+    --+    --   One consequence of the 'UnstableSymbolic' approach is that any+    --   pointer can be derefenced, even if it does not actually point to+    --   anything. Dereferencing such a pointer will simply yield a fresh+    --   symbolic value. On the other hand, dereferencing such a pointer+    --   continues to be a Crucible error in 'StableSymbolic'.+  deriving (Eq, Show)++-- | The default memory model options:+--+-- * Require strict adherence to the language standard regarding pointer+--   equality and ordering.+--+-- * Perform Crucible's default validity checks for memory loads and stores.+defaultMemOptions :: MemOptions+defaultMemOptions =+  MemOptions+  { laxPointerOrdering = False+  , laxConstantEquality = False+  , laxLoadsAndStores = False+    -- The choice of StableSymbolic here doesn't matter too much, since it+    -- won't have any effect when laxLoadsAndStores is disabled.+  , indeterminateLoadBehavior = StableSymbolic+  }+++-- | Like 'defaultMemOptions', but allow pointer ordering comparisons+--   and equality comparisons of pointers to constant data.+laxPointerMemOptions :: MemOptions+laxPointerMemOptions =+  defaultMemOptions+  { laxPointerOrdering = True+  , laxConstantEquality = True+  }
+ src/Lang/Crucible/LLVM/MemModel/Partial.hs view
@@ -0,0 +1,999 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Partial+-- Description      : Operations on partial values in the LLVM memory model+-- Copyright        : (c) Galois, Inc 2015-2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+------------------------------------------------------------------------++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.MemModel.Partial+  ( PartLLVMVal(..)+  , partErr+  , attachSideCondition+  , attachMemoryError+  , assertSafe+  , MemoryError(..)+  , totalLLVMVal+  , bvConcat+  , consArray+  , appendArray+  , mkArray+  , mkStruct+  , HasLLVMAnn+  , LLVMAnnMap+  , BoolAnn(..)+  , annotateME+  , annotateUB+  , projectLLVM_bv++  , floatToBV+  , doubleToBV+  , fp80ToBV+  , bvToDouble+  , bvToFloat+  , bvToX86_FP80+  , selectHighBv+  , selectLowBv+  , arrayElt+  , fieldVal+  , muxLLVMVal++  , CexExplanation(..)+  , explainCex+  ) where++import           Prelude hiding (pred)++import           Control.Lens ((^.), view)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Except (ExceptT, MonadError(..), runExceptT)+import           Control.Monad.State.Strict (StateT, get, put, runStateT)+import qualified Data.ByteString as BS+import qualified Data.Foldable as Fold+import           Data.Maybe (isJust)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Vector (Vector)+import qualified Data.Vector as V+import           Numeric.Natural++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Classes (toOrdering, OrdF(..))+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Some (Some(..))++import           Lang.Crucible.Backend+import           Lang.Crucible.Simulator.SimError+import           Lang.Crucible.Simulator.RegValue (RegValue'(..))+import           Lang.Crucible.LLVM.Bytes (Bytes)+import qualified Lang.Crucible.LLVM.Bytes as Bytes+import           Lang.Crucible.LLVM.MemModel.MemLog (memState)+import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack)+import           Lang.Crucible.LLVM.MemModel.Pointer ( pattern LLVMPointer, LLVMPtr )+import           Lang.Crucible.LLVM.MemModel.Type (StorageType(..), StorageTypeF(..), Field(..))+import qualified Lang.Crucible.LLVM.MemModel.Type as Type+import           Lang.Crucible.LLVM.MemModel.Value (LLVMVal(..))+import qualified Lang.Crucible.LLVM.MemModel.Value as Value+import           Lang.Crucible.LLVM.Errors+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.Errors.MemoryError (MemoryError(..), MemoryErrorReason(..), MemoryOp(..), memOpMem)+import           Lang.Crucible.Panic (panic)++import           What4.Expr+import           What4.Expr.BoolMap+import           What4.Expr.Builder+import           What4.Interface hiding (bvConcat, mkStruct, floatToBV, bvToFloat)+import qualified What4.Interface as W4I+import qualified What4.InterpretedFloatingPoint as W4IFP+++newtype BoolAnn sym = BoolAnn (SymAnnotation sym BaseBoolType)++instance IsSymInterface sym => Eq (BoolAnn sym) where+  BoolAnn x == BoolAnn y = isJust (testEquality x y)+instance IsSymInterface sym => Ord (BoolAnn sym) where+  compare (BoolAnn x) (BoolAnn y) = toOrdering $ compareF x y++type LLVMAnnMap sym = Map (BoolAnn sym) (CallStack, BadBehavior sym)+type HasLLVMAnn sym = (?recordLLVMAnnotation :: CallStack -> BoolAnn sym -> BadBehavior sym -> IO ())++data CexExplanation sym (tp :: BaseType) where+  NoExplanation  :: CexExplanation sym tp+  DisjOfFailures :: [ (CallStack, BadBehavior sym) ] -> CexExplanation sym BaseBoolType++instance Semigroup (CexExplanation sym BaseBoolType) where+  NoExplanation <> y = y+  x <> NoExplanation = x+  DisjOfFailures xs <> DisjOfFailures ys = DisjOfFailures (xs ++ ys)++explainCex :: forall t st fs sym.+  (IsSymInterface sym, sym ~ ExprBuilder t st fs) =>+  sym ->+  LLVMAnnMap sym ->+  Maybe (GroundEvalFn t) ->+  IO (Pred sym -> IO (CexExplanation sym BaseBoolType))+explainCex sym bbMap evalFn =+  do posCache <- newIdxCache+     negCache <- newIdxCache+     pure (evalPos posCache negCache)++  where+  evalPos, evalNeg ::+    IdxCache t (CexExplanation sym) ->+    IdxCache t (CexExplanation sym) ->+    Expr t BaseBoolType ->+    IO (CexExplanation sym BaseBoolType)++  evalPos posCache negCache e = idxCacheEval posCache e $+    case e of+      (asNonceApp -> Just (Annotation BaseBoolRepr annId e')) ->+        case Map.lookup (BoolAnn annId) bbMap of+          Nothing -> evalPos posCache negCache e'+          Just (callStack, bb) ->+            do bb' <- case evalFn of+                        Just f  -> concBadBehavior sym (groundEval f) bb+                        Nothing -> pure bb+               pure (DisjOfFailures [ (callStack, bb') ])++      (asApp -> Just (BaseIte BaseBoolRepr _ c x y))+         | Just f <- evalFn ->+              do c' <- groundEval f c+                 if c' then+                   evalPos posCache negCache x+                 else+                   evalPos posCache negCache y+         | otherwise ->+              (<>) <$> evalPos posCache negCache x <*> evalPos posCache negCache y++      (asApp -> Just (NotPred e')) -> evalNeg posCache negCache e'++      -- We expect at least one of the contained predicates to be false, so choose one+      -- and explain that failure+      (asApp -> Just (ConjPred (viewBoolMap -> BoolMapTerms tms))) -> go (Fold.toList tms)+        where+        go [] = pure NoExplanation+        go ((x,Positive):xs)+          | Just f <- evalFn =+              do x' <- groundEval f x+                 if x' then+                   go xs+                 else+                   evalPos posCache negCache x >>= \case+                     NoExplanation -> go xs+                     ex -> pure ex+          | otherwise =+              -- no counterexample in hand, assume this might be the problem+              evalPos posCache negCache x  >>= \case+                     NoExplanation -> go xs+                     ex -> pure ex++        go ((x,Negative):xs)+          | Just f <- evalFn =+              do x' <- groundEval f x+                 if x' then+                   evalNeg posCache negCache x >>= \case+                     NoExplanation -> go xs+                     ex -> pure ex+                 else+                   go xs+           | otherwise =+              -- no counterexample in hand, assume this might be the problem+              evalNeg posCache negCache x >>= \case+                NoExplanation -> go xs+                ex -> pure ex++      _ -> pure NoExplanation++  evalNeg posCache negCache e = idxCacheEval negCache e $+    case e of+      (asApp -> Just (BaseIte BaseBoolRepr _ c x y))+         | Just f <- evalFn ->+              do c' <- groundEval f c+                 if c' then+                   evalNeg posCache negCache x+                 else+                   evalNeg posCache negCache y+         | otherwise ->+              (<>) <$> evalNeg posCache negCache x <*> evalNeg posCache negCache y++      (asApp -> Just (NotPred e')) -> evalPos posCache negCache e'++      -- under negative polarity, we expect all members of the disjunction to be false,+      -- and we must construct an explanation for all of them+      (asApp -> Just (ConjPred (viewBoolMap -> BoolMapTerms tms))) -> go (Fold.toList tms) NoExplanation+        where+        go [] es = pure es+        go ((x,Positive):xs) es =+          do ex <- evalNeg posCache negCache x+             go xs (ex <> es)+        go ((x,Negative):xs) es =+          do ex <- evalPos posCache negCache x+             go xs (ex <> es)++      _ -> pure NoExplanation++annotateUB :: (IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  CallStack ->+  UB.UndefinedBehavior (RegValue' sym) ->+  Pred sym ->+  IO (Pred sym)+annotateUB sym callStack ub p =+  do (n, p') <- annotateTerm sym p+     ?recordLLVMAnnotation callStack (BoolAnn n) (BBUndefinedBehavior ub)+     return p'++memOpCallStack :: MemoryOp sym w -> CallStack+memOpCallStack = getCallStack . view memState . memOpMem++annotateME :: (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  MemoryErrorReason ->+  Pred sym ->+  IO (Pred sym)+annotateME sym mop rsn p =+  do (n, p') <- annotateTerm sym p+     ?recordLLVMAnnotation+       (memOpCallStack mop)+       (BoolAnn n)+       (BBMemoryError (MemoryError mop rsn))+     return p'++-- | Assert that the given LLVM pointer value is actually a raw bitvector and extract its value.+projectLLVM_bv ::+  IsSymBackend sym bak =>+  bak -> LLVMPtr sym w -> IO (SymBV sym w)+projectLLVM_bv bak (LLVMPointer blk bv) =+  do let sym = backendGetSym bak+     p <- natEq sym blk =<< natLit sym 0+     assert bak p $ AssertFailureSimError "Pointer value coerced to bitvector" ""+     return bv++------------------------------------------------------------------------+-- ** PartLLVMVal++-- | Either an 'LLVMValue' paired with a tree of predicates explaining+-- just when it is actually valid, or a type mismatch.+data PartLLVMVal sym where+  Err :: Pred sym -> PartLLVMVal sym+  NoErr :: Pred sym -> LLVMVal sym -> PartLLVMVal sym++partErr ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  MemoryErrorReason ->+  IO (PartLLVMVal sym)+partErr sym errCtx rsn =+  do p <- annotateME sym errCtx rsn (falsePred sym)+     pure (Err p)++attachSideCondition ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  CallStack ->+  Pred sym ->+  UB.UndefinedBehavior (RegValue' sym) ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+attachSideCondition sym callStack pnew ub pv =+  case pv of+    Err p -> pure (Err p)+    NoErr p v ->+      do p' <- andPred sym p =<< annotateUB sym callStack ub pnew+         return $ NoErr p' v++attachMemoryError ::+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  Pred sym ->+  MemoryOp sym w ->+  MemoryErrorReason ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+attachMemoryError sym pnew mop rsn pv =+  case pv of+    Err p -> pure (Err p)+    NoErr p v ->+      do p' <- andPred sym p =<< annotateME sym mop rsn pnew+         return $ NoErr p' v++typeOfBitvector :: IsExpr (SymExpr sym)+                => proxy sym -> SymBV sym w -> StorageType+typeOfBitvector _ =+  Type.bitvectorType . Bytes.toBytes . natValue . bvWidth++-- | An 'LLVMVal' which is always valid.+totalLLVMVal :: (IsExprBuilder sym)+             => sym+             -> LLVMVal sym+             -> PartLLVMVal sym+totalLLVMVal sym = NoErr (truePred sym)++-- | Take a partial value and assert its safety+assertSafe :: IsSymBackend sym bak+           => bak+           -> PartLLVMVal sym+           -> IO (LLVMVal sym)+assertSafe bak (NoErr p v) =+  do let rsn = AssertFailureSimError "Error during memory load" ""+     assert bak p rsn+     return v++assertSafe bak (Err p) = do+  do let sym = backendGetSym bak+     let rsn = AssertFailureSimError "Error during memory load" ""+     loc <- getCurrentProgramLoc sym+     let err = SimError loc rsn+     addProofObligation bak (LabeledPred p err)+     abortExecBecause (AssertionFailure err)++------------------------------------------------------------------------+-- ** PartLLVMVal interface+--++floatToBV ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+floatToBV _ _ (NoErr p (LLVMValUndef (StorageType Float _))) =+  return (NoErr p (LLVMValUndef (Type.bitvectorType 4)))++floatToBV sym _ (NoErr p (LLVMValZero (StorageType Float _))) =+  do nz <- W4I.natLit sym 0+     iz <- W4I.bvLit sym (knownNat @32) (BV.zero knownNat)+     return (NoErr p (LLVMValInt nz iz))++floatToBV sym _ (NoErr p (LLVMValFloat Value.SingleSize v)) =+  do nz <- natLit sym 0+     i  <- W4IFP.iFloatToBinary sym W4IFP.SingleFloatRepr v+     return (NoErr p (LLVMValInt nz i))++floatToBV _ _ (Err p) = pure (Err p)++floatToBV sym errCtx (NoErr _ v) =+  do let msg = "While converting from a float to a bitvector"+     partErr sym errCtx $+       UnexpectedArgumentType msg [Value.llvmValStorableType v]++doubleToBV ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+doubleToBV _ _ (NoErr p (LLVMValUndef (StorageType Double _))) =+  return (NoErr p (LLVMValUndef (Type.bitvectorType 8)))++doubleToBV sym _ (NoErr p (LLVMValZero (StorageType Double _))) =+  do nz <- W4I.natLit sym 0+     iz <- W4I.bvLit sym (knownNat @64) (BV.zero knownNat)+     return (NoErr p (LLVMValInt nz iz))++doubleToBV sym _ (NoErr p (LLVMValFloat Value.DoubleSize v)) =+  do nz <- natLit sym 0+     i  <- W4IFP.iFloatToBinary sym W4IFP.DoubleFloatRepr v+     return (NoErr p (LLVMValInt nz i))++doubleToBV _ _ (Err p) = pure (Err p)++doubleToBV sym errCtx (NoErr _ v) =+  do let msg = "While converting from a double to a bitvector"+     partErr sym errCtx $+       UnexpectedArgumentType msg [Value.llvmValStorableType v]++fp80ToBV ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+fp80ToBV _ _ (NoErr p (LLVMValUndef (StorageType X86_FP80 _))) =+  return (NoErr p (LLVMValUndef (Type.bitvectorType 10)))++fp80ToBV sym _ (NoErr p (LLVMValZero (StorageType X86_FP80 _))) =+  do nz <- W4I.natLit sym 0+     iz <- W4I.bvLit sym (knownNat @80) (BV.zero knownNat)+     return (NoErr p (LLVMValInt nz iz))++fp80ToBV sym _ (NoErr p (LLVMValFloat Value.X86_FP80Size v)) =+  do nz <- natLit sym 0+     i  <- W4IFP.iFloatToBinary sym W4IFP.X86_80FloatRepr v+     return (NoErr p (LLVMValInt nz i))++fp80ToBV _ _ (Err p) = pure (Err p)++fp80ToBV sym errCtx (NoErr _ v) =+  do let msg = "While converting from a FP80 to a bitvector"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]++-- | Convert a bitvector to a float, asserting that it is not a pointer+bvToFloat :: forall sym w.+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++bvToFloat sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 4) _))) =+  NoErr p . LLVMValFloat Value.SingleSize <$>+    (W4IFP.iFloatFromBinary sym W4IFP.SingleFloatRepr =<<+       W4I.bvLit sym (knownNat @32) (BV.zero knownNat))++bvToFloat sym errCtx (NoErr p (LLVMValInt blk off))+  | Just Refl <- testEquality (bvWidth off) (knownNat @32) = do+      pz <- natEq sym blk =<< natLit sym 0+      let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.floatType+      p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz+      NoErr p' . LLVMValFloat Value.SingleSize <$>+        W4IFP.iFloatFromBinary sym W4IFP.SingleFloatRepr off++bvToFloat _ _ (Err p) = pure (Err p)++bvToFloat sym errCtx (NoErr _ v) =+  do let msg = "While converting from a bitvector to a float"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]+++-- | Convert a bitvector to a double, asserting that it is not a pointer+bvToDouble ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++bvToDouble sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 8) _))) =+  NoErr p . LLVMValFloat Value.DoubleSize <$>+    (W4IFP.iFloatFromBinary sym W4IFP.DoubleFloatRepr =<<+       W4I.bvLit sym (knownNat @64) (BV.zero knownNat))++bvToDouble sym errCtx (NoErr p (LLVMValInt blk off))+  | Just Refl <- testEquality (bvWidth off) (knownNat @64) = do+      pz <- natEq sym blk =<< natLit sym 0+      let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.doubleType+      p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz+      NoErr p' .+        LLVMValFloat Value.DoubleSize <$>+        W4IFP.iFloatFromBinary sym W4IFP.DoubleFloatRepr off++bvToDouble _ _ (Err p) = pure (Err p)++bvToDouble sym errCtx (NoErr _ v) =+  do let msg = "While converting from a bitvector to a double"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]+++-- | Convert a bitvector to an FP80 float, asserting that it is not a pointer+bvToX86_FP80 ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++bvToX86_FP80 sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 10) _))) =+  NoErr p . LLVMValFloat Value.X86_FP80Size <$>+    (W4IFP.iFloatFromBinary sym W4IFP.X86_80FloatRepr =<<+       W4I.bvLit sym (knownNat @80) (BV.zero knownNat))++bvToX86_FP80 sym errCtx (NoErr p (LLVMValInt blk off))+  | Just Refl <- testEquality (bvWidth off) (knownNat @80) =+      do pz <- natEq sym blk =<< natLit sym 0+         let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.x86_fp80Type+         p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz+         NoErr p' . LLVMValFloat Value.X86_FP80Size <$>+           W4IFP.iFloatFromBinary sym W4IFP.X86_80FloatRepr off++bvToX86_FP80 _ _ (Err p) = pure (Err p)++bvToX86_FP80 sym errCtx (NoErr _ v) =+  do let msg = "While converting from a bitvector to a X86_FP80"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]++-- | Concatenate partial LLVM bitvector values. The least-significant+-- (low) bytes are given first. The allocation block number of each+-- argument is asserted to equal 0, indicating non-pointers.+bvConcat :: forall sym w.+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++bvConcat sym errCtx (NoErr p1 v1) (NoErr p2 v2) =+    case (v1, v2) of+      (LLVMValInt blk_low low, LLVMValInt blk_high high) ->+        do go blk_low low blk_high high+      (LLVMValInt blk_low low, LLVMValZero t@(StorageType (Bitvector high_bytes) _)) ->+        Value.zeroInt sym high_bytes $ \case+          Nothing -> partErr sym errCtx $ TypeMismatch (typeOfBitvector (Just sym) low) t+          Just (blk_high, high) ->+            go blk_low low blk_high high+      (LLVMValZero t@(StorageType (Bitvector low_bytes) _), LLVMValInt blk_high high) ->+         Value.zeroInt sym low_bytes $ \case+           Nothing -> partErr sym errCtx $ TypeMismatch (typeOfBitvector (Just sym) high) t+           Just (blk_low, low) ->+             go blk_low low blk_high high+      (LLVMValZero (StorageType (Bitvector low_bytes) _), LLVMValZero (StorageType (Bitvector high_bytes) _)) ->+        pure $ totalLLVMVal sym (LLVMValZero (Type.bitvectorType (low_bytes + high_bytes)))+      (a, b) -> partErr sym errCtx $ UnexpectedArgumentType "While concatenating bitvectors"+                  [Value.llvmValStorableType a, Value.llvmValStorableType b]++ where+  go :: forall l h. (1 <= l, 1 <= h) =>+    SymNat sym -> SymBV sym l -> SymNat sym -> SymBV sym h -> IO (PartLLVMVal sym)+  go blk_low low blk_high high+    -- NB we check that the things we are concatenating are each an integral number of+    -- bytes.  This prevents us from concatenating together the partial-byte writes that+    -- result from e.g. writing an i1 or an i20 into memory.  This is consistent with LLVM+    -- documentation, which says that non-integral number of bytes loads will only succeed+    -- if the value was written orignally with the same type.+    | low_nat  `mod` 8 == 0+    , high_nat `mod` 8 == 0 =+      do blk0   <- natLit sym 0+         -- TODO: Why won't this pattern match fail?+         Just LeqProof <- return $ isPosNat (addNat high_w' low_w')+         let ub1 = UB.PointerIntCast (RV (LLVMPointer blk_low low))   low_tp+             ub2 = UB.PointerIntCast (RV (LLVMPointer blk_high high)) high_tp+             annUB = annotateUB sym (memOpCallStack errCtx)+         predLow       <- annUB ub1 =<< natEq sym blk_low blk0+         predHigh      <- annUB ub2 =<< natEq sym blk_high blk0+         bv            <- W4I.bvConcat sym high low++         p' <- andPred sym p1 =<< andPred sym p2 =<< andPred sym predLow predHigh+         return $ NoErr p' (LLVMValInt blk0 bv)++    | otherwise = partErr sym errCtx $+        UnexpectedArgumentType "Non-byte-sized bitvectors"+          [Value.llvmValStorableType v1, Value.llvmValStorableType v2]++    where low_w'  = bvWidth low+          low_nat = natValue low_w'+          low_tp  = Type.bitvectorType (Bytes.bitsToBytes low_nat)++          high_w'  = bvWidth high+          high_nat = natValue high_w'+          high_tp  = Type.bitvectorType (Bytes.bitsToBytes high_nat)++bvConcat sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2+bvConcat _ _ _ (Err e) = pure (Err e)+bvConcat _ _ (Err e) _ = pure (Err e)++-- | Cons an element onto a partial LLVM array value.+consArray ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+consArray sym _ (NoErr p1 (LLVMValZero tp)) (NoErr p2 (LLVMValZero (StorageType (Array m tp') _)))+  | tp == tp' =+      do p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValZero (Type.arrayType (m+1) tp')++consArray sym _ (NoErr p1 hd) (NoErr p2 (LLVMValZero (StorageType (Array m tp) _)))+  | Value.llvmValStorableType hd == tp =+      do p' <- andPred sym p1 p2+         return $ NoErr p' $+           LLVMValArray tp (V.cons hd (V.replicate (fromIntegral m) (LLVMValZero tp)))++consArray sym _ (NoErr p1 (LLVMValInt blk off)) (NoErr p2 (LLVMValString bs))+  | Just Refl <- testEquality (bvWidth off) (knownNat @8)+  , Just 0    <- asNat blk+  , Just bv   <- asBV off+  = do p' <- andPred sym p1 p2+       return $ NoErr p' (LLVMValString (BS.cons (fromInteger (BV.asUnsigned bv)) bs))++consArray sym errCtx (NoErr p1 v) (NoErr p2 (LLVMValString bs))+  = consArray sym errCtx (NoErr p1 v) . NoErr p2 =<< Value.explodeStringValue sym bs++consArray sym _ (NoErr p1 hd) (NoErr p2 (LLVMValArray tp vec))+  | Value.llvmValStorableType hd == tp =+      do p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValArray tp (V.cons hd vec)++consArray sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2+consArray _ _ (Err e) _ = pure (Err e)+consArray _ _ _ (Err e) = pure (Err e)++consArray sym errCtx _ (NoErr _ v) =+  partErr sym errCtx $ UnexpectedArgumentType "Non-array value" [Value.llvmValStorableType v]++-- | Append two partial LLVM array values.+appendArray ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  PartLLVMVal sym ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+appendArray sym _+  (NoErr p1 (LLVMValZero (StorageType (Array n1 tp1) _)))+  (NoErr p2 (LLVMValZero (StorageType (Array n2 tp2) _)))+  | tp1 == tp2 =+      do p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValZero (Type.arrayType (n1+n2) tp1)++appendArray sym _+  (NoErr p1 (LLVMValString bs1))+  (NoErr p2 (LLVMValString bs2))+  = do p' <- andPred sym p1 p2+       pure $ NoErr p' $ LLVMValString (bs1 <> bs2)++appendArray sym errCtx (NoErr p1 (LLVMValString bs1)) (NoErr p2 v2)+  = do bsv <- Value.explodeStringValue sym bs1+       appendArray sym errCtx (NoErr p1 bsv) (NoErr p2 v2)++appendArray sym errCtx (NoErr p1 v1) (NoErr p2 (LLVMValString bs2))+  = do bsv <- Value.explodeStringValue sym bs2+       appendArray sym errCtx (NoErr p1 v1) (NoErr p2 bsv)++appendArray sym _+  (NoErr p1 (LLVMValZero (StorageType (Array n1 tp1) _)))+  (NoErr p2 (LLVMValArray tp2 v2))+  | tp1 == tp2 =+      do let v1 = V.replicate (fromIntegral n1) (LLVMValZero tp1)+         p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2)++appendArray sym _+  (NoErr p1 (LLVMValArray tp1 v1))+  (NoErr p2 (LLVMValZero (StorageType (Array n2 tp2) _)))+  | tp1 == tp2 =+      do let v2 = V.replicate (fromIntegral n2) (LLVMValZero tp1)+         p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2)++appendArray sym _+  (NoErr p1 (LLVMValArray tp1 v1))+  (NoErr p2 (LLVMValArray tp2 v2))+  | tp1 == tp2 =+      do p' <- andPred sym p1 p2+         return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2)++appendArray sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2+appendArray _ _ (Err e) _ = pure (Err e)+appendArray _ _ _ (Err e) = pure (Err e)++appendArray sym errCtx (NoErr _ v1) (NoErr _ v2) =+  partErr sym errCtx $ UnexpectedArgumentType "Non-array value when appending arrays"+          [Value.llvmValStorableType v1, Value.llvmValStorableType v2]++-- | Make a partial LLVM array value.+--+-- It returns 'Err' if any of the elements of the vector are+-- 'Err'. Otherwise, the 'Pred' on the returned 'NoErr' value+-- is the 'And' of all the assertions on the values.+mkArray :: forall sym. (IsExprBuilder sym, IsSymInterface sym) =>+  sym ->+  StorageType ->+  Vector (PartLLVMVal sym) ->+  IO (PartLLVMVal sym)+mkArray sym tp vec =+  do let f :: PartLLVMVal sym -> StateT (Pred sym) (ExceptT (Pred sym) IO) (LLVMVal sym)+         f (Err e) = throwError e+         f (NoErr p x) = do+           pd <- get     -- Current predicates+           pd' <- liftIO $ andPred sym pd p+           put pd'    -- Append this one+           return x+     (runExceptT $ flip runStateT (truePred sym) $ traverse f vec) >>= \case+        Left e -> pure $ Err e+        Right (vec', p) -> return $ NoErr p (LLVMValArray tp vec')+++-- | Make a partial LLVM struct value.+--+-- It returns 'Err' if any of the struct fields are 'Err'.+-- Otherwise, the 'Pred' on the returned 'NoErr' value is the 'And' of all the+-- assertions on the values.+mkStruct :: forall sym. IsExprBuilder sym =>+  sym ->+  Vector (Field StorageType, PartLLVMVal sym) ->+  IO (PartLLVMVal sym)+mkStruct sym vec =+  do let f :: (Field StorageType, PartLLVMVal sym) ->+              StateT (Pred sym) (ExceptT (Pred sym) IO) (Field StorageType, LLVMVal sym)+         f (_, Err e)       = throwError e+         f (fld, NoErr p x) = do+           pd <- get+           pd' <- liftIO $ andPred sym pd p+           put pd'+           pure (fld, x)++     (runExceptT $ flip runStateT (truePred sym) $ traverse f vec) >>= \case+       Left e -> pure (Err e)+       Right (vec',p) -> return $ NoErr p (LLVMValStruct vec')++-- | Select some of the least significant bytes of a partial LLVM+-- bitvector value. The allocation block number of the argument is+-- asserted to equal 0, indicating a non-pointer.+selectLowBv ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  Bytes ->+  Bytes ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++selectLowBv _sym _ low hi (NoErr p (LLVMValZero (StorageType (Bitvector bytes) _)))+  | low + hi == bytes =+      return $ NoErr p $ LLVMValZero (Type.bitvectorType low)++selectLowBv sym errCtx low hi (NoErr p (LLVMValInt blk bv))+  | Just (Some (low_w)) <- someNat (Bytes.bytesToBits low)+  , Just (Some (hi_w))  <- someNat (Bytes.bytesToBits hi)+  , Just LeqProof       <- isPosNat low_w+  , Just Refl           <- testEquality (addNat low_w hi_w) w+  , Just LeqProof       <- testLeq low_w w =+      do pz  <- natEq sym blk =<< natLit sym 0+         bv' <- bvSelect sym (knownNat :: NatRepr 0) low_w bv+         let ub = UB.PointerIntCast (RV (LLVMPointer blk bv)) tp+         p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz+         return $ NoErr p' $ LLVMValInt blk bv'+ where w = bvWidth bv+       tp = Type.bitvectorType (Bytes.bitsToBytes (natValue w))++selectLowBv sym errCtx _ _ (NoErr _ v) =+  do let msg = "While selecting the low bits of a bitvector"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]++selectLowBv _ _ _ _ (Err e) = pure (Err e)++-- | Select some of the most significant bytes of a partial LLVM+-- bitvector value. The allocation block number of the argument is+-- asserted to equal 0, indicating a non-pointer.+selectHighBv ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  Bytes ->+  Bytes ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)++selectHighBv _sym _ low hi (NoErr p (LLVMValZero (StorageType (Bitvector bytes) _)))+  | low + hi == bytes =+      return $ NoErr p $ LLVMValZero (Type.bitvectorType hi)++selectHighBv sym errCtx low hi (NoErr p (LLVMValInt blk bv))+  | Just (Some (low_w)) <- someNat (Bytes.bytesToBits low)+  , Just (Some (hi_w))  <- someNat (Bytes.bytesToBits hi)+  , Just LeqProof <- isPosNat hi_w+  , Just Refl <- testEquality (addNat low_w hi_w) w =+    do pz <-  natEq sym blk =<< natLit sym 0+       bv' <- bvSelect sym low_w hi_w bv+       let ub = UB.PointerIntCast (RV (LLVMPointer blk bv)) tp+       p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz+       return $ NoErr p' $ LLVMValInt blk bv'+  where w = bvWidth bv+        tp = Type.bitvectorType (Bytes.bitsToBytes (natValue w))+selectHighBv _ _ _ _ (Err e) = pure (Err e)++selectHighBv sym errCtx _ _ (NoErr _ v) =+  do let msg = "While selecting the high bits of a bitvector"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]+++-- | Look up an element in a partial LLVM array value.+arrayElt ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  Natural ->+  StorageType ->+  Natural ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+arrayElt _ _ sz tp idx (NoErr p (LLVMValZero _)) -- TODO(langston) typecheck+  | 0 <= idx+  , idx < sz =+    return $ NoErr p (LLVMValZero tp)++arrayElt sym _ sz tp idx (NoErr p (LLVMValString bs))+  | sz == fromIntegral (BS.length bs)+  , 0 <= idx+  , idx < sz+  , tp == Type.bitvectorType (Bytes.Bytes 1)+  = do blk <- natLit sym 0+       off <- bvLit sym (knownNat @8) (BV.word8 (BS.index bs (fromIntegral idx)))+       return $ NoErr p (LLVMValInt blk off)++arrayElt _ _ sz tp idx (NoErr p (LLVMValArray tp' vec))+  | sz == fromIntegral (V.length vec)+  , 0 <= idx+  , idx < sz+  , tp == tp' =+    return $ NoErr p (vec V.! fromIntegral idx)++arrayElt _ _ _ _ _ (Err e) = pure (Err e)++arrayElt sym errCtx _ _ _ (NoErr _ v) =+  do let msg = "While selecting and element of an array"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]++-- | Look up a field in a partial LLVM struct value.+fieldVal ::+  (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) =>+  sym ->+  MemoryOp sym w ->+  (Vector (Field StorageType)) ->+  Int ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+fieldVal _ _ flds idx (NoErr p (LLVMValZero _)) -- TODO(langston) typecheck+  | 0 <= idx+  , idx < V.length flds =+      return $ NoErr p $ LLVMValZero $ view Type.fieldVal $ flds V.! idx++fieldVal _ _ flds idx (NoErr p (LLVMValStruct vec))+  | flds == fmap fst vec+  , 0 <= idx+  , idx < V.length vec =+    return $ NoErr p $ snd $ (vec V.! idx)++fieldVal _ _ _ _ (Err e) = pure (Err e)++fieldVal sym errCtx _ _ (NoErr _ v) =+  do let msg = "While getting a struct field"+     partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v]++------------------------------------------------------------------------+-- ** Merging and muxing+--++-- | If-then-else on partial expressions.+merge :: forall sym m. (IsSymInterface sym, HasLLVMAnn sym, MonadIO m) =>+  sym ->+  (Pred sym -> LLVMVal sym -> LLVMVal sym -> m (LLVMVal sym))+    {- ^ Operation to combine inner values. The 'Pred' parameter is the+         if/then/else condition -} ->+  Pred sym {- ^ condition to merge on -} ->+  PartLLVMVal sym {- ^ 'then' value -}  ->+  PartLLVMVal sym {- ^ 'else' value -} ->+  m (PartLLVMVal sym)+merge sym _ c (Err e1) (Err e2) = Err <$> liftIO (itePred sym c e1 e2)++merge sym _ cond (NoErr p v) (Err pe) =+  do p' <- liftIO (itePred sym cond p pe)+     pure $ NoErr p' v+merge sym _ cond (Err pe) (NoErr p v) = do+  do p' <- liftIO (itePred sym cond pe p)+     pure $ NoErr p' v+merge sym f cond (NoErr px x) (NoErr py y) = do+  v <- f cond x y+  p' <- liftIO (itePred sym cond px py)+  return $ NoErr p' v++-- | Mux partial LLVM values.+--+--   Will @panic@ if the values are not structurally related.+--   This should never happen, as we only call @muxLLVMVal@+--   from inside the memory model as we read values, and the+--   shape of values is determined by the memory type+--   at which we read values.+muxLLVMVal :: forall sym.+  (IsSymInterface sym, HasLLVMAnn sym) =>+  sym ->+  Pred sym ->+  PartLLVMVal sym ->+  PartLLVMVal sym ->+  IO (PartLLVMVal sym)+muxLLVMVal sym = merge sym muxval+  where++    muxzero :: Pred sym -> StorageType -> LLVMVal sym -> IO (LLVMVal sym)+    muxzero cond tpz val = case val of+      LLVMValZero tp -> return $ LLVMValZero tp+      LLVMValUndef tpu ->+        -- TODO: Is this the right behavior?+        panic "Cannot mux zero and undef" [ "Zero type: " ++ show tpz+                                          , "Undef type: " ++ show tpu+                                          ]++      LLVMValString bs -> muxzero cond tpz =<< Value.explodeStringValue sym bs++      LLVMValInt base off ->+        do zbase <- W4I.natLit sym 0+           zoff  <- W4I.bvLit sym (W4I.bvWidth off) (BV.zero (W4I.bvWidth off))+           base' <- W4I.natIte sym cond zbase base+           off'  <- W4I.bvIte sym cond zoff off+           return $ LLVMValInt base' off'+      LLVMValFloat Value.SingleSize x ->+        do zerof <- (W4IFP.iFloatLitRational sym W4IFP.SingleFloatRepr 0)+           x'    <- (W4IFP.iFloatIte @_ @W4IFP.SingleFloat sym cond zerof x)+           return $ LLVMValFloat Value.SingleSize x'+      LLVMValFloat Value.DoubleSize x ->+        do zerof <- (W4IFP.iFloatLitRational sym W4IFP.DoubleFloatRepr 0)+           x'    <- (W4IFP.iFloatIte @_ @W4IFP.DoubleFloat sym cond zerof x)+           return $ LLVMValFloat Value.DoubleSize x'+      LLVMValFloat Value.X86_FP80Size x ->+        do zerof <- (W4IFP.iFloatLitRational sym W4IFP.X86_80FloatRepr 0)+           x'    <- (W4IFP.iFloatIte @_ @W4IFP.X86_80Float sym cond zerof x)+           return $ LLVMValFloat Value.X86_FP80Size x'++      LLVMValArray tp vec -> LLVMValArray tp <$>+        traverse (muxzero cond tp) vec++      LLVMValStruct flds -> LLVMValStruct <$>+        traverse (\(fld, v) -> (fld,) <$>+                     muxzero cond (fld^.Type.fieldVal) v) flds+++    muxval :: Pred sym -> LLVMVal sym -> LLVMVal sym -> IO (LLVMVal sym)+    muxval cond (LLVMValZero tp) v = muxzero cond tp v+    muxval cond v (LLVMValZero tp) = do cond' <- notPred sym cond+                                        muxzero cond' tp v++    muxval cond (LLVMValInt base1 off1) (LLVMValInt base2 off2)+      | Just Refl <- testEquality (bvWidth off1) (bvWidth off2)+      = do base <- liftIO $ natIte sym cond base1 base2+           off  <- liftIO $ bvIte sym cond off1 off2+           pure $ LLVMValInt base off++    muxval cond (LLVMValFloat (xsz :: Value.FloatSize fi) x) (LLVMValFloat ysz y)+      | Just Refl <- testEquality xsz ysz+      = LLVMValFloat xsz <$>+          (liftIO $ W4IFP.iFloatIte @_ @fi sym cond x y)++    muxval cond (LLVMValStruct fls1) (LLVMValStruct fls2)+      | fmap fst fls1 == fmap fst fls2 =+          LLVMValStruct <$>+            V.zipWithM (\(f, x) (_, y) -> (f,) <$> muxval cond x y) fls1 fls2++    muxval cond (LLVMValString bs1) (LLVMValString bs2)+      | bs1 == bs2 = pure (LLVMValString bs1)+      | BS.length bs1 == BS.length bs2+      =  do v1 <- Value.explodeStringValue sym bs1+            v2 <- Value.explodeStringValue sym bs2+            muxval cond v1 v2++    muxval cond (LLVMValString bs) v@LLVMValArray{}+      = do bsv <- Value.explodeStringValue sym bs+           muxval cond bsv v++    muxval cond v@LLVMValArray{} (LLVMValString bs)+      = do bsv <- Value.explodeStringValue sym bs+           muxval cond v bsv++    muxval cond (LLVMValArray tp1 v1) (LLVMValArray tp2 v2)+      | tp1 == tp2 && V.length v1 == V.length v2 = do+          LLVMValArray tp1 <$> V.zipWithM (muxval cond) v1 v2++    muxval _ v1@(LLVMValUndef tp1) (LLVMValUndef tp2)+      | tp1 == tp2 = pure v1++    muxval _ v1 v2 =+      panic "Cannot mux LLVM values"+        [ "v1: " ++ show v1+        , "v2: " ++ show v2+        ]
+ src/Lang/Crucible/LLVM/MemModel/Pointer.hs view
@@ -0,0 +1,350 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Pointer+-- Description      : Representation of pointers in the LLVM memory model+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Lang.Crucible.LLVM.MemModel.Pointer+  ( -- * Pointer bitwidth+    HasPtrWidth+  , pattern PtrWidth+  , withPtrWidth++    -- * Crucible pointer representation+  , LLVMPointerType+  , LLVMPtr+  , SomePointer(..)+  , pattern LLVMPointerRepr+  , pattern PtrRepr+  , pattern SizeT+  , pattern LLVMPointer+  , ptrWidth+  , llvmPointerView+  , llvmPointerBlock+  , llvmPointerOffset+  , llvmPointerType+  , muxLLVMPtr+  , llvmPointer_bv+  , mkNullPointer++    -- * Concretization+  , concBV+  , concPtr+  , concPtr'++    -- * Operations on valid pointers+  , constOffset+  , ptrEq+  , ptrLe+  , ptrAdd+  , ptrDiff+  , ptrSub+  , ptrIsNull+  , isGlobalPointer+  , isGlobalPointer'++    -- * Pretty printing+  , ppPtr++    -- * Annotation+  , annotatePointerBlock+  , annotatePointerOffset+  ) where++import           Control.Monad (guard)+import           Data.Map (Map)+import qualified Data.Map as Map (lookup)+import           Numeric.Natural+import           Prettyprinter++import           GHC.TypeLits (TypeError, ErrorMessage(..))+import           GHC.TypeNats++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Classes+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr+import qualified Text.LLVM.AST as L++import           What4.Interface+import           What4.InterpretedFloatingPoint+import           What4.Expr (GroundValue)++import           Lang.Crucible.Backend+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.Intrinsics+import           Lang.Crucible.Types+import qualified Lang.Crucible.LLVM.Bytes as G+import           Lang.Crucible.LLVM.Types+import           Lang.Crucible.LLVM.MemModel.Options++++data LLVMPointer sym w =+  -- |A pointer is a base point offset.+  LLVMPointer (SymNat sym) (SymBV sym w)++deriving instance (Show (SymNat sym), Show (SymBV sym w)) => Show (LLVMPointer sym w)++llvmPointerBlock :: LLVMPtr sym w -> SymNat sym+llvmPointerBlock (LLVMPointer blk _) = blk++llvmPointerOffset :: LLVMPtr sym w -> SymBV sym w+llvmPointerOffset (LLVMPointer _ off) = off++llvmPointerType :: IsExpr (SymExpr sym) => LLVMPtr sym w -> TypeRepr (LLVMPointerType w)+llvmPointerType ptr =+  case exprType (llvmPointerOffset ptr) of+    BaseBVRepr w -> LLVMPointerRepr w++-- | Type family defining how @LLVMPointerType@ unfolds.+type family LLVMPointerImpl sym ctx where+  LLVMPointerImpl sym (EmptyCtx ::> BVType w) = LLVMPointer sym w+  LLVMPointerImpl sym ctx = TypeError ('Text "LLVM_pointer expects a single argument of BVType, but was given" ':<>:+                                       'ShowType ctx)++-- | A pointer with an existentially-quantified width+data SomePointer sym = forall w. (1 <= w) => SomePointer !(LLVMPtr sym w)++instance (IsSymInterface sym) => IntrinsicClass sym "LLVM_pointer" where+  type Intrinsic sym "LLVM_pointer" ctx = LLVMPointerImpl sym ctx++  muxIntrinsic sym _iTypes _nm (Ctx.Empty Ctx.:> (BVRepr _w)) = muxLLVMPtr sym+  muxIntrinsic _ _ nm ctx = typeError nm ctx++-- | Alternative to the 'LLVMPointer' pattern synonym, this function can be used as a view+--   constructor instead to silence incomplete pattern warnings.+llvmPointerView :: LLVMPtr sym w -> (SymNat sym, SymBV sym w)+llvmPointerView (LLVMPointer blk off) = (blk, off)++-- | Compute the width of a pointer value.+ptrWidth :: IsExprBuilder sym => LLVMPtr sym w -> NatRepr w+ptrWidth (LLVMPointer _blk bv) = bvWidth bv++-- | Convert a raw bitvector value into an LLVM pointer value.+llvmPointer_bv :: IsSymInterface sym => sym -> SymBV sym w -> IO (LLVMPtr sym w)+llvmPointer_bv sym bv =+  do blk0 <- natLit sym 0+     return (LLVMPointer blk0 bv)++-- | Produce the distinguished null pointer value.+mkNullPointer :: (1 <= w, IsSymInterface sym) => sym -> NatRepr w -> IO (LLVMPtr sym w)+mkNullPointer sym w = llvmPointer_bv sym =<< bvLit sym w (BV.zero w)+++concBV ::+  (IsExprBuilder sym, 1 <= w) =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  SymBV sym w -> IO (SymBV sym w)+concBV sym conc bv =+  do bv' <- conc bv+     bvLit sym (bvWidth bv) bv'++concPtr ::+  (IsExprBuilder sym, 1 <= w) =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  RegValue sym (LLVMPointerType w) ->+  IO (RegValue sym (LLVMPointerType w))+concPtr sym conc (LLVMPointer blk off) =+  do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk+     off' <- concBV sym conc off+     pure (LLVMPointer blk' off')++concPtr' ::+  (IsExprBuilder sym, 1 <= w) =>+  sym ->+  (forall tp. SymExpr sym tp -> IO (GroundValue tp)) ->+  RegValue' sym (LLVMPointerType w) ->+  IO (RegValue' sym (LLVMPointerType w))+concPtr' sym conc (RV ptr) = RV <$> concPtr sym conc ptr+++-- | Mux function specialized to LLVM pointer values.+muxLLVMPtr ::+  (1 <= w) =>+  IsSymInterface sym =>+  sym ->+  Pred sym ->+  LLVMPtr sym w ->+  LLVMPtr sym w ->+  IO (LLVMPtr sym w)+muxLLVMPtr sym p (LLVMPointer b1 off1) (LLVMPointer b2 off2) =+  do b   <- natIte sym p b1 b2+     off <- bvIte sym p off1 off2+     return $ LLVMPointer b off++data FloatSize (fi :: FloatInfo) where+  SingleSize :: FloatSize SingleFloat+  DoubleSize :: FloatSize DoubleFloat++deriving instance Eq (FloatSize fi)++deriving instance Ord (FloatSize fi)++deriving instance Show (FloatSize fi)++instance TestEquality FloatSize where+  testEquality SingleSize SingleSize = Just Refl+  testEquality DoubleSize DoubleSize = Just Refl+  testEquality _ _ = Nothing++-- | Generate a concrete offset value from an @Addr@ value.+constOffset :: (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> G.Addr -> IO (SymBV sym w)+constOffset sym w x = bvLit sym w (G.bytesToBV w x)++-- | Test whether two pointers are equal.+ptrEq :: (1 <= w, IsSymInterface sym)+      => sym+      -> NatRepr w+      -> LLVMPtr sym w+      -> LLVMPtr sym w+      -> IO (Pred sym)+ptrEq sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2) =+  do p1 <- natEq sym base1 base2+     p2 <- bvEq sym off1 off2+     andPred sym p1 p2++-- | Test whether one pointer is less than or equal to the other.+--+-- The returned predicates assert (in this order):+--  * the first pointer is less than or equal to the second+--  * the comparison is valid: the pointers are to the same allocation+ptrLe :: (1 <= w, IsSymInterface sym, ?memOpts :: MemOptions)+      => sym+      -> NatRepr w+      -> LLVMPtr sym w+      -> LLVMPtr sym w+      -> IO (Pred sym, Pred sym)+ptrLe sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2)+  | laxPointerOrdering ?memOpts+  = do plt <- natLt sym base1 base2+       peq <- natEq sym base1 base2+       bvle <- bvUle sym off1 off2++       p <- orPred sym plt =<< andPred sym peq bvle+       return (p, truePred sym)++  | otherwise+  = do peq <- natEq sym base1 base2+       bvle <- bvUle sym off1 off2+       return (bvle, peq)++-- | Add an offset to a pointer.+ptrAdd :: (1 <= w, IsExprBuilder sym)+       => sym+       -> NatRepr w+       -> LLVMPtr sym w+       -> SymBV sym w+       -> IO (LLVMPtr sym w)+ptrAdd sym _w (LLVMPointer base off1) off2 =+  LLVMPointer base <$> bvAdd sym off1 off2++-- | Compute the difference between two pointers. The returned predicate asserts+-- that the pointers point into the same allocation block.+ptrDiff :: (1 <= w, IsSymInterface sym)+        => sym+        -> NatRepr w+        -> LLVMPtr sym w+        -> LLVMPtr sym w+        -> IO (SymBV sym w, Pred sym)+ptrDiff sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2) =+  (,) <$> bvSub sym off1 off2 <*> natEq sym base1 base2++-- | Subtract an offset from a pointer.+ptrSub :: (1 <= w, IsSymInterface sym)+       => sym+       -> NatRepr w+       -> LLVMPtr sym w+       -> SymBV sym w+       -> IO (LLVMPtr sym w)+ptrSub sym _w (LLVMPointer base off1) off2 =+  do diff <- bvSub sym off1 off2+     return (LLVMPointer base diff)++-- | Test if a pointer value is the null pointer.+ptrIsNull :: (1 <= w, IsSymInterface sym)+          => sym+          -> NatRepr w+          -> LLVMPtr sym w+          -> IO (Pred sym)+ptrIsNull sym w (LLVMPointer blk off) =+  do pblk <- natEq sym blk =<< natLit sym 0+     poff <- bvEq sym off =<< bvLit sym (bvWidth off) (BV.zero w)+     andPred sym pblk poff++ppPtr :: IsExpr (SymExpr sym) => LLVMPtr sym wptr -> Doc ann+ppPtr (llvmPointerView -> (blk, bv))+  | Just 0 <- asNat blk = printSymExpr bv+  | otherwise =+     let blk_doc = printSymNat blk+         off_doc = printSymExpr bv+      in pretty "(" <> blk_doc <> pretty "," <+> off_doc <> pretty ")"++-- | Look up a pointer in the 'memImplGlobalMap' to see if it's a global.+--+-- This is best-effort and will only work if the pointer is fully concrete+-- and matches the address of the global on the nose. It is used in SAWscript+-- for friendly error messages.+isGlobalPointer ::+  forall sym w. (IsSymInterface sym) =>+  Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} ->+  LLVMPtr sym w -> Maybe L.Symbol+isGlobalPointer symbolMap needle =+  do n <- asNat (llvmPointerBlock needle)+     z <- asBV (llvmPointerOffset needle)+     guard (BV.asUnsigned z == 0)+     Map.lookup n symbolMap++-- | For when you don't know @1 <= w@+isGlobalPointer' ::+  forall sym w. (IsSymInterface sym) =>+  Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} ->+  LLVMPtr sym w -> Maybe L.Symbol+isGlobalPointer' symbolMap needle =+  case testLeq (knownNat :: NatRepr 1) (ptrWidth needle) of+    Nothing       -> Nothing+    Just LeqProof -> isGlobalPointer symbolMap needle++annotatePointerBlock ::+  forall sym w. (IsSymInterface sym) =>+  sym ->+  LLVMPtr sym w ->+  IO (SymAnnotation sym BaseIntegerType, LLVMPointer sym w)+annotatePointerBlock sym (LLVMPointer blk off) =+  do (annotation, annotatedBlkInt) <- annotateTerm sym =<< natToInteger sym blk+     annotatedBlkNat <- integerToNat sym annotatedBlkInt+     pure (annotation, LLVMPointer annotatedBlkNat off)++annotatePointerOffset ::+  forall sym w. (IsSymInterface sym) =>+  sym ->+  LLVMPtr sym w ->+  IO (SymAnnotation sym (BaseBVType w), LLVMPointer sym w)+annotatePointerOffset sym (LLVMPointer blk off) =+  do (annotation, annotatedOff) <- annotateTerm sym off+     pure (annotation, LLVMPointer blk annotatedOff)
+ src/Lang/Crucible/LLVM/MemModel/Type.hs view
@@ -0,0 +1,167 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Type+-- Description      : Representation of storable types used by the memory model+-- Copyright        : (c) Galois, Inc 2011-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Lang.Crucible.LLVM.MemModel.Type+  ( -- * Storable types+    StorageType(..)+  , StorageTypeF(..)+  , bitvectorType+  , floatType+  , doubleType+  , x86_fp80Type+  , arrayType+  , structType+  , mkStructType+  , mkStorageType+  , typeEnd+  , Field+  , fieldVal+  , fieldPad+  , fieldOffset+  , mkField+  , ppType+  )  where++import Control.Lens+import Control.Monad.State+import Data.Typeable+import Data.Vector (Vector)+import qualified Data.Vector as V+import Numeric.Natural+import Prettyprinter++import Lang.Crucible.LLVM.Bytes++data Field v =+  Field+  { fieldOffset :: !Offset+  , _fieldVal   :: !v+  , fieldPad    :: !Bytes+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Typeable)++fieldVal :: Lens (Field a) (Field b) a b+fieldVal = lens _fieldVal (\s v -> s { _fieldVal = v })++mkField :: Offset -> v -> Bytes -> Field v+mkField = Field++data StorageTypeF v+  = Bitvector !Bytes -- ^ Size of bitvector in bytes (must be > 0).+  | Float+  | Double+  | X86_FP80+  | Array !Natural !v -- ^ Number of elements and element type+  | Struct !(Vector (Field v))+  deriving (Eq, Ord, Show, Typeable)++-- | Represents the storage type of an LLVM value. A 'Type' specifies+-- how a value is represented as bytes in memory.+data StorageType =+  StorageType+  { storageTypeF :: !(StorageTypeF StorageType)+  , storageTypeSize :: !Bytes+  }+  deriving (Eq, Ord, Typeable)++instance Show StorageType where+  showsPrec p t = showParen (p >= 10) $+    case storageTypeF t of+      Bitvector w -> showString "bitvectorType " . shows w+      Float -> showString "float"+      Double -> showString "double"+      X86_FP80 -> showString "long double"+      Array n tp -> showString "arrayType " . shows n . showString " " . showsPrec 10 tp+      Struct v -> showString "mkStructType " . shows (V.toList (fldFn <$> v))+        where fldFn f = (f^.fieldVal, fieldPad f)++mkStorageType :: StorageTypeF StorageType -> StorageType+mkStorageType tf = StorageType tf $+  case tf of+    Bitvector w -> w+    Float -> 4+    Double -> 8+    X86_FP80 -> 10+    Array n e -> natBytesMul n (storageTypeSize e)+    Struct flds -> structSize flds++bitvectorType :: Bytes -> StorageType+bitvectorType w = StorageType (Bitvector w) w++floatType :: StorageType+floatType = mkStorageType Float++doubleType :: StorageType+doubleType = mkStorageType Double++x86_fp80Type :: StorageType+x86_fp80Type = mkStorageType X86_FP80++arrayType :: Natural -> StorageType -> StorageType+arrayType n e = StorageType (Array n e) (natBytesMul n (storageTypeSize e))++structType :: V.Vector (Field StorageType) -> StorageType+structType flds = StorageType (Struct flds) (structSize flds)++mkStructType :: V.Vector (StorageType, Bytes) -> StorageType+mkStructType l = structType (evalState (traverse fldFn l) 0)+  where+    fldFn (tp,p) =+      do o <- get+         put $! o + storageTypeSize tp + p+         return Field { fieldOffset = o+                      , _fieldVal = tp+                      , fieldPad = p+                      }++-- | Returns end of actual type bytes (excluded padding from structs).+typeEnd :: Addr -> StorageType -> Addr+typeEnd a tp = seq a $+  case storageTypeF tp of+    Bitvector w -> a + w+    Float -> a + 4+    Double -> a + 8+    X86_FP80 -> a + 10+    Array 0 _   -> a+    Array n etp -> typeEnd (a + natBytesMul (n-1) (storageTypeSize etp)) etp+    Struct flds ->+      case V.unsnoc flds of+        Just (_, f) -> typeEnd (a + fieldOffset f) (f^.fieldVal)+        Nothing -> a++-- | Returns end of field including padding bytes.+structSize :: V.Vector (Field StorageType) -> Bytes+structSize flds =+  case V.unsnoc flds of+    Just (_, f) -> fieldEnd f+    Nothing -> 0++-- | Returns end of field including padding bytes.+fieldEnd :: Field StorageType -> Bytes+fieldEnd f = fieldOffset f + storageTypeSize (f^.fieldVal) + fieldPad f+++-- | Pretty print type.+ppType :: StorageType -> Doc ann+ppType tp =+  case storageTypeF tp of+    Bitvector w -> pretty 'i' <> pretty (bytesToBits w)+    Float -> pretty "float"+    Double -> pretty "double"+    X86_FP80 -> pretty "long double"+    Array n etp -> brackets (pretty n <+> pretty 'x' <+> ppType etp)+    Struct flds -> braces $ hsep $ punctuate (pretty ',') $ V.toList $ ppFld <$> flds+      where ppFld f = ppType (f^.fieldVal)
+ src/Lang/Crucible/LLVM/MemModel/Value.hs view
@@ -0,0 +1,420 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemModel.Value+-- Description      : Representation of values in the LLVM memory model+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Lang.Crucible.LLVM.MemModel.Value+  ( -- * LLVM Value representation+    LLVMVal(..)+  , ppLLVMValWithGlobals+  , FloatSize(..)+  , Field+  , ptrToPtrVal+  , zeroInt+  , ppTermExpr+  , explodeStringValue++  , llvmValStorableType+  , freshLLVMVal+  , isZero+  , testEqual+  ) where++import           Control.Lens (view, over, _2, (^.))+import           Control.Monad (foldM, join)+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import           Data.Map (Map)+import           Data.Foldable (toList)+import           Data.Functor.Identity (Identity(..))+import           Data.Maybe (fromMaybe, mapMaybe)+import           Data.List (intersperse)+import           Numeric.Natural+import           Prettyprinter++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Classes+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Some+import           Data.Vector (Vector)+import qualified Data.Vector as V+import qualified Text.LLVM.AST as L++import           What4.Interface+import           What4.InterpretedFloatingPoint++import           Lang.Crucible.Backend+import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.MemModel.Type+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.Panic (panic)++data FloatSize (fi :: FloatInfo) where+  SingleSize :: FloatSize SingleFloat+  DoubleSize :: FloatSize DoubleFloat+  X86_FP80Size :: FloatSize X86_80Float++deriving instance Eq (FloatSize fi)+deriving instance Ord (FloatSize fi)+deriving instance Show (FloatSize fi)+instance TestEquality FloatSize where+  testEquality SingleSize SingleSize = Just Refl+  testEquality DoubleSize DoubleSize = Just Refl+  testEquality X86_FP80Size X86_FP80Size = Just Refl+  testEquality _ _ = Nothing++-- | This datatype describes the variety of values that can be stored in+--   the LLVM heap.+data LLVMVal sym where+  -- | NOTE! The ValInt constructor uniformly represents both pointers and+  -- raw bitvector values.  The 'SymNat' value is an allocation block number+  -- that identifies specific allocations.  The block number '0' is special,+  -- and indicates that this value is actually a bitvector.  Non-zero block+  -- numbers correspond to pointer values, where the 'SymBV' value is an+  -- offset from the base pointer of the allocation.+  LLVMValInt :: (1 <= w) => SymNat sym -> SymBV sym w -> LLVMVal sym+  LLVMValFloat :: FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym+  LLVMValStruct :: Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym+  LLVMValArray :: StorageType -> Vector (LLVMVal sym) -> LLVMVal sym++  -- | LLVM Value Data given by a constant string of bytes+  LLVMValString :: ByteString -> LLVMVal sym++  -- | The zero value exists at all storage types, and represents the the value+  -- which is obtained by loading the approprite number of all zero bytes.+  -- It is useful for compactly representing large zero-initialized data structures.+  LLVMValZero :: StorageType -> LLVMVal sym++  -- | The @undef@ value exists at all storage types.+  LLVMValUndef :: StorageType -> LLVMVal sym+++llvmValStorableType :: IsExprBuilder sym => LLVMVal sym -> StorageType+llvmValStorableType v =+  case v of+    LLVMValInt _ bv -> bitvectorType (bitsToBytes (natValue (bvWidth bv)))+    LLVMValFloat SingleSize _ -> floatType+    LLVMValFloat DoubleSize _ -> doubleType+    LLVMValFloat X86_FP80Size _ -> x86_fp80Type+    LLVMValStruct fs -> structType (fmap fst fs)+    LLVMValArray tp vs -> arrayType (fromIntegral (V.length vs)) tp+    LLVMValString bs -> arrayType (fromIntegral (BS.length bs)) (bitvectorType (Bytes 1))+    LLVMValZero tp -> tp+    LLVMValUndef tp -> tp++-- | Create a fresh 'LLVMVal' of the given type.+freshLLVMVal :: IsSymInterface sym =>+                sym -> StorageType -> IO (LLVMVal sym)+freshLLVMVal sym tp =+  case storageTypeF tp of+    Bitvector bytes ->+      case mkNatRepr (bytesToBits bytes) of+        Some repr ->+          case isPosNat repr of+            Just LeqProof -> LLVMValInt <$> natLit sym 0+                                        <*> freshConstant sym emptySymbol (BaseBVRepr repr)+            Nothing -> panic "freshLLVMVal" ["Non-positive value inside Bytes"]+    Float      -> LLVMValFloat SingleSize <$> freshFloatConstant sym emptySymbol SingleFloatRepr+    Double     -> LLVMValFloat DoubleSize <$> freshFloatConstant sym emptySymbol DoubleFloatRepr+    X86_FP80   -> LLVMValFloat X86_FP80Size <$> freshFloatConstant sym emptySymbol X86_80FloatRepr+    Array n ty -> LLVMValArray ty <$> V.replicateM (fromIntegral n) (freshLLVMVal sym ty)+    Struct vec -> LLVMValStruct <$> traverse (\v -> (v,) <$> freshLLVMVal sym (v^.fieldVal)) vec++ppTermExpr :: forall sym ann.+  IsExpr (SymExpr sym) => LLVMVal sym -> Doc ann+ppTermExpr t = -- FIXME, do something with the predicate?+  case t of+    LLVMValZero _tp -> pretty "0"+    LLVMValUndef tp -> pretty "<undef : " <> viaShow tp <> pretty ">"+    LLVMValString bs -> viaShow bs+    LLVMValInt base off -> ppPtr @sym (LLVMPointer base off)+    LLVMValFloat _ v -> printSymExpr v+    LLVMValStruct v -> encloseSep lbrace rbrace comma v''+      where v'  = fmap (over _2 ppTermExpr) (V.toList v)+            v'' = map (\(fld,doc) ->+                        group (pretty "base+" <> viaShow (fieldOffset fld) <+> equals <+> doc))+                      v'+    LLVMValArray _tp v -> encloseSep lbracket rbracket comma v'+      where v' = ppTermExpr <$> V.toList v++-- | Coerce an 'LLVMPtr' value into a memory-storable 'LLVMVal'.+ptrToPtrVal :: (1 <= w) => LLVMPtr sym w -> LLVMVal sym+ptrToPtrVal (LLVMPointer blk off) = LLVMValInt blk off++zeroInt ::+  IsSymInterface sym =>+  sym ->+  Bytes ->+  (forall w. (1 <= w) => Maybe (SymNat sym, SymBV sym w) -> IO a) ->+  IO a+zeroInt sym bytes k+   | Some w <- mkNatRepr (bytesToBits bytes)+   , Just LeqProof <- isPosNat w+   =   do blk <- natLit sym 0+          bv  <- bvLit sym w (BV.zero w)+          k (Just (blk, bv))+zeroInt _ _ k = k @1 Nothing++-- | Pretty-print an 'LLVMVal'.+--+-- This is parameterized over how to display pointers, see+-- 'ppLLVMValWithGlobals'.+ppLLVMVal ::+  (Applicative f, IsExpr (SymExpr sym)) =>+  (forall w. SymNat sym -> SymBV sym w -> f (Maybe (Doc ann)))+    {- ^ Printing of pointers -} ->+  LLVMVal sym ->+  f (Doc ann)+ppLLVMVal ppInt =+  let typed doc tp = pretty doc <+> pretty ":" <+> viaShow tp+      pp = ppLLVMVal ppInt+  in+    \case+      (LLVMValZero tp) -> pure $ angles (typed "zero" tp)+      (LLVMValUndef tp) -> pure $ angles (typed "undef" tp)+      (LLVMValString bs) -> pure $ viaShow bs+      (LLVMValInt blk w) -> fromMaybe otherDoc <$> ppInt blk w+        where+          otherDoc =+            case asNat blk of+              Just 0 ->+                case (asBV w) of+                  (Just (BV.BV unsigned)) -> pretty $ unwords $+                    [ "literal integer:"+                    , "unsigned value = " ++ show unsigned ++ ","+                    , unwords [ "signed value = "+                              , show (toSigned (bvWidth w) unsigned) ++ ","+                              ]+                    , "width = " ++ show (bvWidth w)+                    ]+                  Nothing -> pretty $ unwords $+                    [ "symbolic integer: "+                    , "width = " ++ show (bvWidth w)+                    ]+              Just n ->+                case asBV w of+                  Just (BV.BV offset) -> pretty $ unwords $+                    [ "concrete pointer:"+                    , "allocation = " ++ show n ++ ","+                    , "offset = " ++ show offset+                    ]+                  Nothing -> pretty $ unwords $+                    [ "pointer with concrete allocation and symbolic offset:"+                    , "allocation = " ++ show n+                    ]++              Nothing ->+                case asBV w of+                  Just (BV.BV offset) -> pretty $+                    "pointer with concrete offset " ++ show offset+                  Nothing -> pretty "pointer with symbolic offset"++      (LLVMValFloat SingleSize _) -> pure $ pretty "symbolic float"+      (LLVMValFloat DoubleSize _) -> pure $ pretty "symbolic double"+      (LLVMValFloat X86_FP80Size _) -> pure $ pretty "symbolic long double"+      (LLVMValStruct xs) -> encloseSep lbrace rbrace semi <$> traverse (pp . snd) (V.toList xs)+      (LLVMValArray _ xs) -> list <$> traverse pp (V.toList xs)++-- | Pretty-print an 'LLVMVal', but replace pointers to globals with the name of+--   the global when possible. Probably pretty slow on big structures.+ppLLVMValWithGlobals ::+  forall sym ann.+  (IsSymInterface sym) =>+  sym ->+  Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} ->+  LLVMVal sym ->+  Doc ann+ppLLVMValWithGlobals _sym symbolMap = runIdentity . ppLLVMVal ppInt+  where+    ppInt :: forall w. SymNat sym -> SymBV sym w -> Identity (Maybe (Doc ann))+    ppInt allocNum offset =+      pure (ppSymbol <$> isGlobalPointer' @sym symbolMap (LLVMPointer allocNum offset))+    ppSymbol (L.Symbol symb) = pretty ('@' : symb)++-- | This instance tries to make things as concrete as possible.+instance IsExpr (SymExpr sym) => Pretty (LLVMVal sym) where+  pretty x = runIdentity $ ppLLVMVal (\_ _ -> Identity Nothing) x++instance IsExpr (SymExpr sym) => Show (LLVMVal sym) where+  show (LLVMValZero _tp) = "0"+  show (LLVMValUndef tp) = "<undef : " ++ show tp ++ ">"+  show (LLVMValString  _) = "<string>"+  show (LLVMValInt blk w)+    | Just 0 <- asNat blk = "<int" ++ show (bvWidth w) ++ ">"+    | otherwise = "<ptr " ++ show (bvWidth w) ++ ">"+  show (LLVMValFloat SingleSize _) = "<float>"+  show (LLVMValFloat DoubleSize _) = "<double>"+  show (LLVMValFloat X86_FP80Size _) = "<long double>"+  show (LLVMValStruct xs) =+    unwords $ [ "{" ]+           ++ intersperse ", " (map (show . snd) $ V.toList xs)+           ++ [ "}" ]+  show (LLVMValArray _ xs) =+    unwords $ [ "[" ]+           ++ intersperse ", " (map show $ V.toList xs)+           ++ [ "]" ]++-- | An efficient n-way @and@: it quits early if it finds any concretely false+-- values, rather than chaining a bunch of 'andPred's.+allOf :: (IsExprBuilder sym)+      => sym+      -> [Pred sym]+      -> IO (Pred sym)+allOf sym xs =+  if and (mapMaybe asConstantPred xs)+  then foldM (andPred sym) (truePred sym) xs+  else pure (falsePred sym)++{-+-- | An efficient n-way @or@: it quits early if it finds any concretely false+-- values, rather than chaining a bunch of 'orPred's.+oneOf :: (IsExprBuilder sym)+      => sym+      -> [Pred sym]+      -> IO (Pred sym)+oneOf sym xs =+  if or (mapMaybe asConstantPred xs)+  then pure (truePred sym)+  else foldM (orPred sym) (falsePred sym) xs+-}++-- | Commute an applicative with Maybe+commuteMaybe :: Applicative n => Maybe (n a) -> n (Maybe a)+commuteMaybe (Just val) = Just <$> val+commuteMaybe Nothing    = pure Nothing++-- | This should be used with caution: it is very inefficient to expand zeroes,+-- especially to large data structures (e.g. long arrays).+zeroExpandLLVMVal :: (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym)+                  => sym -> StorageType -> IO (LLVMVal sym)+zeroExpandLLVMVal sym (StorageType tpf _sz) =+  case tpf of+    Bitvector bytes ->+      case mkNatRepr (bytesToBits bytes) of+        Some (repr :: NatRepr w) ->+          case testNatCases (knownNat @0) repr of+            NatCaseLT (LeqProof :: LeqProof 1 w) ->+              LLVMValInt <$> natLit sym 0 <*> bvLit sym repr (BV.zero repr)+            NatCaseEQ -> panic "zeroExpandLLVMVal" ["Zero value inside Bytes"]+            NatCaseGT (LeqProof :: LeqProof (w + 1) 0) ->+              panic "zeroExpandLLVMVal" ["Impossible: (w + 1) </= 0"]+    Float    -> LLVMValFloat SingleSize <$> iFloatPZero sym SingleFloatRepr+    Double   -> LLVMValFloat DoubleSize <$> iFloatPZero sym DoubleFloatRepr+    X86_FP80 -> LLVMValFloat X86_FP80Size <$> iFloatPZero sym X86_80FloatRepr+    Array n ty+      | toInteger n <= toInteger (maxBound :: Int) ->+        LLVMValArray ty . V.replicate (fromIntegral n :: Int) <$>+          zeroExpandLLVMVal sym ty+      | otherwise -> panic "zeroExpandLLVMVal" ["Array length too large", show n]+    Struct vec ->+      LLVMValStruct <$>+        V.zipWithM (\f t -> (f,) <$> zeroExpandLLVMVal sym t) vec (fmap (view fieldVal) vec)++-- | A special case for comparing values to the distinguished zero value.+--+-- Should be faster than using 'testEqual' with 'zeroExpandLLVMVal' for compound+-- values, because we 'traverse' subcomponents of vectors and structs, quitting+-- early on a constantly false answer or 'LLVMValUndef'.+--+-- Returns 'Nothing' for 'LLVMValUndef'.+isZero :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym)+       => sym -> LLVMVal sym -> IO (Maybe (Pred sym))+isZero sym v =+  case v of+    LLVMValStruct fs  -> areZero' (fmap snd fs)+    LLVMValArray _ vs -> areZero' vs+    LLVMValString bs  -> pure $ Just $ backendPred sym $ not $ isJust $ BS.find (/= 0) bs+    LLVMValZero _     -> pure (Just $ truePred sym)+    LLVMValUndef _    -> pure Nothing+    _                 ->+      -- For atomic types, we simply expand and compare.+      testEqual sym v =<< zeroExpandLLVMVal sym (llvmValStorableType v)+  where+    areZero :: Traversable t => t (LLVMVal sym) -> IO (Maybe (t (Pred sym)))+    areZero = fmap sequence . traverse (isZero sym)+    areZero' :: Traversable t => t (LLVMVal sym) -> IO (Maybe (Pred sym))+    areZero' vs =+      -- This could probably be simplified with a well-placed =<<...+      join $ fmap commuteMaybe $ fmap (fmap (allOf sym . toList)) $ areZero vs++-- | A predicate denoting the equality of two LLVMVals.+--+-- Returns 'Nothing' in the event that one of the values contains 'LLVMValUndef'.+testEqual :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym)+          => sym -> LLVMVal sym -> LLVMVal sym -> IO (Maybe (Pred sym))+testEqual sym v1 v2 =+  case (v1, v2) of+    (LLVMValInt blk1 off1, LLVMValInt blk2 off2) ->+      case testEquality (bvWidth off1) (bvWidth off2) of+        Nothing   -> false+        Just Refl ->+          natEq sym blk1 blk2 >>= \p1 ->+            Just <$> (andPred sym p1 =<< bvEq sym off1 off2)+    (LLVMValFloat (sz1 :: FloatSize fi1) flt1, LLVMValFloat sz2 flt2) ->+      case testEquality sz1 sz2 of+        Nothing   -> false+        Just Refl -> Just <$> iFloatEq @_ @fi1 sym flt1 flt2+    (LLVMValArray tp1 vec1, LLVMValArray tp2 vec2) ->+      andAlso (tp1 == tp2 && V.length vec1 == V.length vec2) (allEqual vec1 vec2)+    (LLVMValStruct vec1, LLVMValStruct vec2) ->+      let (si1, si2) = (fmap fst vec1, fmap fst vec2)+          (fd1, fd2) = (fmap snd vec1, fmap snd vec2)+      in andAlso (V.length vec1 == V.length vec2 && V.and (V.zipWith (==) si1 si2))+                 (allEqual fd1 fd2)++    (LLVMValString bs1, LLVMValString bs2) -> if bs1 == bs2 then true else false+    (LLVMValString bs, v@LLVMValArray{}) ->+      do bsv <- explodeStringValue sym bs+         testEqual sym bsv v+    (v@LLVMValArray{}, LLVMValString bs) ->+      do bsv <- explodeStringValue sym bs+         testEqual sym v bsv++    (LLVMValZero tp1, LLVMValZero tp2) -> if tp1 == tp2 then true else false+    (LLVMValZero tp, other) -> compareZero tp other+    (other, LLVMValZero tp) -> compareZero tp other+    (LLVMValUndef _, _) -> pure Nothing+    (_, LLVMValUndef _) -> pure Nothing+    (_, _) -> false -- type mismatch++  where true = pure (Just $ truePred sym)+        false = pure (Just $ falsePred sym)++        andAlso b x = if b then x else false++        allEqual vs1 vs2 =+          foldM (\x y -> commuteMaybe (andPred sym <$> x <*> y)) (Just $ truePred sym) =<<+            V.zipWithM (testEqual sym) vs1 vs2++        -- This is probably inefficient:+        compareZero tp other =+          andAlso (llvmValStorableType other == tp) $ isZero sym other+++-- | Turns a bytestring into an explicit array of bytes+explodeStringValue :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) =>+  sym -> ByteString -> IO (LLVMVal sym)+explodeStringValue sym bs =+  do blk <- natLit sym 0+     vs <- V.generateM (BS.length bs)+              (\i -> LLVMValInt blk <$> bvLit sym (knownNat @8) (BV.word8 (BS.index bs i)))+     pure (LLVMValArray (bitvectorType (Bytes 1)) vs)
+ src/Lang/Crucible/LLVM/MemType.hs view
@@ -0,0 +1,397 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.MemType+-- Description      : Basic datatypes for describing LLVM types+-- Copyright        : (c) Galois, Inc 2011-2013+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.MemType+  ( -- * Type information.+    SymType(..)+  , MemType(..)+  , memTypeAlign+  , memTypeSize+  , ppSymType+  , ppMemType+  , memTypeBitwidth+  , isPointerMemType+    -- ** Function type information.+  , FunDecl(..)+  , RetType+  , voidFunDecl+  , funDecl+  , varArgsFunDecl+  , ppFunDecl+  , ppRetType+    -- ** Struct type information.+  , StructInfo+  , siIsPacked+  , mkStructInfo+  , siFieldCount+  , FieldInfo+  , fiOffset+  , fiType+  , fiPadding+  , siFieldInfo+  , siFieldTypes+  , siFieldOffset+  , siFields+  , siIndexOfOffset+    -- ** Common memory types.+  , i1, i8, i16, i32, i64+  , i8p, i16p, i32p, i64p+    -- * Re-exports+  , L.Ident(..)+  , ppIdent+  ) where++import Control.Lens+import Data.Vector (Vector)+import qualified Data.Vector as V+import Numeric.Natural+import qualified Text.LLVM as L+import Prettyprinter++import Lang.Crucible.LLVM.Bytes+import Lang.Crucible.LLVM.DataLayout+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import Lang.Crucible.LLVM.PrettyPrint hiding (ppIdent, ppType)+import Lang.Crucible.Panic ( panic )++-- | Performs a binary search on a range of ints.+binarySearch :: (Int -> Ordering)+             -> Int -- ^ Lower bound (included in range)+             -> Int -- ^ Upper bound (excluded from range)+             -> Maybe Int+binarySearch f = go+  where go l h | l == h = Nothing+               | otherwise = case f i of+                               -- Index is less than one f is searching for+                               LT -> go (i+1) h+                               EQ -> Just i+                               -- Index is greater than one f is searching for.+                               GT -> go l i+          where i = l + (h - l) `div` 2++ppIdent :: L.Ident -> Doc ann+ppIdent = viaShow . LPP.ppIdent+-- TODO: update if llvm-pretty switches to prettyprinter++-- | LLVM types supported by symbolic simulator.+data SymType+  = MemType MemType+  | Alias L.Ident+  | FunType FunDecl+  | VoidType+    -- | A type that LLVM does not know the structure of such as+    -- a struct that is declared, but not defined.+  | OpaqueType+    -- | A type not supported by the symbolic simulator.+  | UnsupportedType L.Type+  deriving (Eq, Ord)++instance Show SymType where+  show = show . ppSymType++instance Pretty SymType where+  pretty = ppSymType++-- | Pretty-print a 'SymType'.+ppSymType :: SymType -> Doc ann+ppSymType (MemType tp) = ppMemType tp+ppSymType (Alias i) = ppIdent i+ppSymType (FunType d) = ppFunDecl d+ppSymType VoidType = pretty "void"+ppSymType OpaqueType = pretty "opaque"+ppSymType (UnsupportedType tp) = viaShow (LPP.ppType tp)+-- TODO: update if llvm-pretty switches to prettyprinter++-- | LLVM types supported by simulator with a defined size and alignment.+data MemType+  = IntType Natural+  | PtrType SymType+    -- ^ A pointer with an explicit pointee type, corresponding to LLVM's+    -- 'L.PtrTo'.+  | PtrOpaqueType+    -- ^ An opaque pointer type, corresponding to LLVM's 'L.PtrOpaque'.+  | FloatType+  | DoubleType+  | X86_FP80Type+  | ArrayType Natural MemType+  | VecType Natural MemType+  | StructType StructInfo+  | MetadataType+  deriving (Eq, Ord)++instance Show MemType where+  show = show . ppMemType++instance Pretty MemType where+  pretty = ppMemType++-- | Pretty-print a 'MemType'.+ppMemType :: MemType -> Doc ann+ppMemType mtp =+  case mtp of+    IntType w -> ppIntType w+    FloatType -> pretty "float"+    DoubleType -> pretty "double"+    X86_FP80Type -> pretty "long double"+    PtrType tp -> ppPtrType (ppSymType tp)+    PtrOpaqueType -> pretty "ptr"+    ArrayType n tp -> ppArrayType n (ppMemType tp)+    VecType n tp  -> ppVectorType n (ppMemType tp)+    StructType si -> ppStructInfo si+    MetadataType -> pretty "metadata"++-- | 1-bit integer type.+i1 :: MemType+i1 = IntType 1++-- | 8-bit integer type.+i8 :: MemType+i8 = IntType 8++-- | 16-bit integer type.+i16 :: MemType+i16 = IntType 16++-- | 32-bit integer type.+i32 :: MemType+i32 = IntType 32++-- | 64-bit integer type.+i64 :: MemType+i64 = IntType 64++-- | Pointer to 8-bit integer.+i8p :: MemType+i8p = PtrType (MemType i8)++-- | Pointer to 16-bit integer.+i16p :: MemType+i16p = PtrType (MemType i16)++-- | Pointer to 32-bit integer.+i32p :: MemType+i32p = PtrType (MemType i32)++-- | Pointer to 64-bit integer.+i64p :: MemType+i64p = PtrType (MemType i64)++-- | An LLVM function type.+data FunDecl = FunDecl { fdRetType  :: !RetType+                       , fdArgTypes :: ![MemType]+                       , fdVarArgs  :: !Bool+                       }+ deriving (Eq, Ord)++-- | Return the number of bits that represent the given memtype, which+--   must be either integer types, floating point types or vectors of+--   the same.+memTypeBitwidth :: MemType -> Maybe Natural+memTypeBitwidth (IntType w)  = Just w+memTypeBitwidth FloatType    = Just 32+memTypeBitwidth DoubleType   = Just 64+memTypeBitwidth X86_FP80Type = Just 80+memTypeBitwidth (VecType n tp) = (fromIntegral n *) <$> memTypeBitwidth tp+memTypeBitwidth _ = Nothing++-- | Returns 'True' if this is a pointer type.+isPointerMemType :: MemType -> Bool+isPointerMemType (PtrType _)   = True+isPointerMemType PtrOpaqueType = True+isPointerMemType _             = False++-- | Return type if any.+type RetType = Maybe MemType++-- | Declare function that returns void.+voidFunDecl :: [MemType] -> FunDecl+voidFunDecl tps = FunDecl { fdRetType = Nothing+                          , fdArgTypes = tps+                          , fdVarArgs = False+                          }++-- | Declare function that returns a value.+funDecl :: MemType -> [MemType] -> FunDecl+funDecl rtp tps = FunDecl { fdRetType = Just rtp+                          , fdArgTypes = tps+                          , fdVarArgs = False+                          }++-- | Declare function that returns a value.+varArgsFunDecl :: MemType -> [MemType] -> FunDecl+varArgsFunDecl rtp tps = FunDecl { fdRetType = Just rtp+                                 , fdArgTypes = tps+                                 , fdVarArgs = True+                                 }++-- | Pretty-print a function type.+ppFunDecl :: FunDecl -> Doc ann+ppFunDecl (FunDecl rtp args va) = rdoc <> parens (commas (fmap ppMemType args ++ vad))+  where rdoc = maybe (pretty "void") ppMemType rtp+        vad = if va then [pretty "..."] else []++-- | Pretty print a return type.+ppRetType :: RetType -> Doc ann+ppRetType = maybe (pretty "void") ppMemType++-- | Returns size of a 'MemType' in bytes.+memTypeSize :: DataLayout -> MemType -> Bytes+memTypeSize dl mtp =+  case mtp of+    IntType w -> intWidthSize w+    FloatType -> 4+    DoubleType -> 8+    X86_FP80Type -> 10+    PtrType{} -> dl ^. ptrSize+    PtrOpaqueType{} -> dl ^. ptrSize+    ArrayType n tp -> natBytesMul n (memTypeSize dl tp)+    VecType n tp -> natBytesMul n (memTypeSize dl tp)+    StructType si -> structSize si+    MetadataType -> 0++memTypeSizeInBits :: DataLayout -> MemType -> Natural+memTypeSizeInBits dl tp = bytesToBits (memTypeSize dl tp)++-- | Returns ABI byte alignment constraint in bytes.+memTypeAlign :: DataLayout -> MemType -> Alignment+memTypeAlign dl mtp =+  case mtp of+    IntType w -> integerAlignment dl (fromIntegral w)+    FloatType -> case floatAlignment dl 32 of+                   Just a -> a+                   Nothing -> panic "crucible-llvm:memTypeAlign.float32"+                              [ "Invalid 32-bit float alignment from datalayout" ]+    DoubleType -> case floatAlignment dl 64 of+                    Just a -> a+                    Nothing -> panic "crucible-llvm:memTypeAlign.float64"+                               [ "Invalid 64-bit float alignment from datalayout" ]+    X86_FP80Type -> case floatAlignment dl 80 of+                      Just a -> a+                      Nothing -> panic "crucible-llvm:memTypeAlign.float80"+                                 [ "Invalid 80-bit float alignment from datalayout" ]+    PtrType{} -> dl ^. ptrAlign+    PtrOpaqueType{} -> dl ^. ptrAlign+    ArrayType _ tp -> memTypeAlign dl tp+    VecType _n _tp -> vectorAlignment dl (memTypeSizeInBits dl mtp)+    StructType si  -> structAlign si+    MetadataType   -> noAlignment++-- | Information about size, alignment, and fields of a struct.+data StructInfo = StructInfo+  { siIsPacked   :: !Bool+  , structSize   :: !Bytes -- ^ Size in bytes.+  , structAlign  :: !Alignment+  , siFields     :: !(V.Vector FieldInfo)+  }+  deriving (Eq, Ord, Show)++data FieldInfo = FieldInfo+  { fiOffset    :: !Offset  -- ^ Byte offset of field relative to start of struct.+  , fiType      :: !MemType -- ^ Type of field.+  , fiPadding   :: !Bytes   -- ^ Number of bytes of padding at end of field.+  }+  deriving (Eq, Ord, Show)+++-- | Constructs a function for obtaining target-specific size/alignment+-- information about structs.  The function produced corresponds to the+-- @StructLayout@ object constructor in TargetData.cpp.+mkStructInfo :: DataLayout+             -> Bool -- ^ @True@ = packed, @False@ = unpacked+             -> [MemType] -- ^ Field types+             -> StructInfo+mkStructInfo dl packed tps0 = go [] 0 a0 tps0+  where a0 | packed    = noAlignment+           | otherwise = nextAlign noAlignment tps0 `max` aggregateAlignment dl+        -- Padding after each field depends on the alignment of the+        -- type of the next field, if there is one. Padding after the+        -- last field depends on the alignment of the whole struct+        -- (i.e. the maximum alignment of any field). Alignment value+        -- of n means to align on 2^n byte boundaries.+        nextAlign :: Alignment -> [MemType] -> Alignment+        nextAlign _ _ | packed = noAlignment+        nextAlign maxAlign [] = maxAlign+        nextAlign _ (tp:_) = memTypeAlign dl tp++        -- Process fields+        go :: [FieldInfo] -- ^ Fields so far in reverse order.+           -> Bytes       -- ^ Total size so far (aligned to next element)+           -> Alignment   -- ^ Maximum alignment so far+           -> [MemType]   -- ^ Field types to process+           -> StructInfo++        go flds sz maxAlign (tp:tpl) =+          go (fi:flds) sz' (max maxAlign fieldAlign) tpl++          where+            fi = FieldInfo+                   { fiOffset  = sz+                   , fiType    = tp+                   , fiPadding = sz' - e+                   }++            -- End of field for tp+            e = sz + memTypeSize dl tp++            -- Alignment of next field+            fieldAlign = nextAlign maxAlign tpl++            -- Size of field at alignment for next thing.+            sz' = padToAlignment e fieldAlign++        go flds sz maxAlign [] =+            StructInfo { siIsPacked = packed+                       , structSize = sz+                       , structAlign = maxAlign+                       , siFields = V.fromList (reverse flds)+                       }++-- | The types of a struct type's fields.+siFieldTypes :: StructInfo -> Vector MemType+siFieldTypes si = fiType <$> siFields si++-- | Number of fields in a struct type.+siFieldCount :: StructInfo -> Int+siFieldCount = V.length . siFields++-- | Returns information for field with given index, if it is defined.+siFieldInfo :: StructInfo -> Int -> Maybe FieldInfo+siFieldInfo si i = siFields si V.!? i++-- | Returns offset of field with given index, if it is defined.+siFieldOffset :: StructInfo -> Int -> Maybe Offset+siFieldOffset si i = fiOffset <$> siFieldInfo si i++-- | Returns index of field at the given byte offset (if any).+siIndexOfOffset :: StructInfo -> Offset -> Maybe Int+siIndexOfOffset si o = binarySearch f 0 (V.length flds)+  where flds = siFields si+        f i | e <= o = LT -- Index too low if field ends before offset.+            | o < s  = GT -- Index too high if field starts after offset.+            | otherwise = EQ+         where s = fiOffset (flds V.! i)+               e | i+1 == V.length flds = structSize si+                 | otherwise = fiOffset (flds V.! i)++commas :: [Doc ann] -> Doc ann+commas = hsep . punctuate (pretty ',')++structBraces :: Bool -> Doc ann -> Doc ann+structBraces False b = pretty '{' <+> b <+> pretty '}'+structBraces True  b = pretty "<{" <+> b <+> pretty "}>"++-- | Pretty print struct info.+ppStructInfo :: StructInfo -> Doc ann+ppStructInfo si = structBraces (siIsPacked si) $ commas (V.toList fields)+  where fields = ppMemType <$> siFieldTypes si
+ src/Lang/Crucible/LLVM/PrettyPrint.hs view
@@ -0,0 +1,97 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.PrettyPrint+-- Description      : Printing utilties for LLVM+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- This module defines several functions whose names clash with functions+-- offered elsewhere in @llvm-pretty@ (e.g., "Text.LLVM.PP") and in+-- @crucible-llvm@ (e.g., "Lang.Crucible.LLVM.MemModel.MemLog"). For this+-- reason, it is recommended to import this module qualified.+------------------------------------------------------------------------++{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}+module Lang.Crucible.LLVM.PrettyPrint+  ( commaSepList+  , ppIntType+  , ppPtrType+  , ppArrayType+  , ppVectorType+  , ppIntVector++    -- * @llvm-pretty@ printing with the latest LLVM version+  , ppLLVMLatest+  , ppDeclare+  , ppIdent+  , ppSymbol+  , ppType+  , ppValue+  ) where++import Numeric.Natural+import Prettyprinter+import qualified Text.PrettyPrint.HughesPJ as HPJ++import qualified Text.LLVM.AST as L+import qualified Text.LLVM.PP as L++-- | Print list of documents separated by commas and spaces.+commaSepList :: [Doc ann] -> Doc ann+commaSepList l = hcat (punctuate (comma <> pretty ' ') l)++-- | Pretty print int type with width.+ppIntType :: Integral a => a -> Doc ann+ppIntType i = pretty 'i' <> pretty (toInteger i)++-- | Pretty print pointer type.+ppPtrType :: Doc ann -> Doc ann+ppPtrType tp = tp <> pretty '*'++ppArrayType :: Natural -> Doc ann -> Doc ann+ppArrayType n e = brackets (pretty (toInteger n) <+> pretty 'x' <+> e)++ppVectorType :: Natural -> Doc ann -> Doc ann+ppVectorType n e = angles (pretty (toInteger n) <+> pretty 'x' <+> e)++ppIntVector :: Integral a => Natural -> a -> Doc ann+ppIntVector n w = ppVectorType n (ppIntType w)++-- | Pretty-print an LLVM-related AST in accordance with the latest LLVM version+-- that @llvm-pretty@ currently supports (i.e., the value of 'L.llvmVlatest'.)+--+-- Note that we are mainly using the @llvm-pretty@ printer in @crucible-llvm@+-- for the sake of defining 'Show' instances and creating error messages, not+-- for creating machine-readable LLVM code. As a result, it doesn't particularly+-- matter which LLVM version we use, as any version-specific differences in+-- pretty-printer output won't be that impactful.+ppLLVMLatest :: ((?config :: L.Config) => a) -> a+ppLLVMLatest = L.withConfig (L.Config { L.cfgVer = L.llvmVlatest })++-- | Invoke 'L.ppDeclare' in accordance with the latest LLVM version that+-- @llvm-pretty@ supports.+ppDeclare :: L.Declare -> HPJ.Doc+ppDeclare = ppLLVMLatest L.ppDeclare++-- | Invoke 'L.ppIdent' in accordance with the latest LLVM version that+-- @llvm-pretty@ supports.+ppIdent :: L.Ident -> HPJ.Doc+ppIdent = ppLLVMLatest L.ppIdent++-- | Invoke 'L.ppSymbol' in accordance with the latest LLVM version that+-- @llvm-pretty@ supports.+ppSymbol :: L.Symbol -> HPJ.Doc+ppSymbol = ppLLVMLatest L.ppSymbol++-- | Invoke 'L.ppType' in accordance with the latest LLVM version that+-- @llvm-pretty@ supports.+ppType :: L.Type -> HPJ.Doc+ppType = ppLLVMLatest L.ppType++-- | Invoke 'L.ppValue' in accordance with the latest LLVM version that+-- @llvm-pretty@ supports.+ppValue :: L.Value -> HPJ.Doc+ppValue = ppLLVMLatest L.ppValue
+ src/Lang/Crucible/LLVM/Printf.hs view
@@ -0,0 +1,475 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Printf+-- Description      : Interpretation of 'printf' style conversion codes+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- A model of C's @printf@ function. This does not entirely conform to the C+-- standard's specification of @printf@; see @doc/limitations.md@ for the+-- specifics.+--+------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Lang.Crucible.LLVM.Printf+( PrintfFlag(..)+, PrintfLengthModifier(..)+, Case(..)+, IntFormat(..)+, FloatFormat(..)+, PrintfConversionType(..)+, PrintfDirective(..)+, parseDirectives+, ConversionDirective(..)+, PrintfOperations(..)+, executeDirectives+, formatInteger+, formatRational+) where++import           Data.Char (toUpper)+import qualified Numeric as N+import           Control.Applicative+import           Data.Attoparsec.ByteString.Char8 hiding (take)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Word+import qualified GHC.Stack as GHC++data PrintfFlag+  = PrintfAlternateForm   -- #+  | PrintfZeroPadding     -- 0+  | PrintfNegativeWidth   -- -+  | PrintfPosSpace        -- ' '+  | PrintfPosPlus         -- ++  | PrintfThousandsSep    -- '+ deriving (Eq,Ord,Show)++data PrintfLengthModifier+  = Len_Byte                  -- hh+  | Len_Short                 -- h+  | Len_Long                  -- l+  | Len_LongLong              -- ll+  | Len_LongDouble            -- L+  | Len_IntMax                -- j+  | Len_PtrDiff               -- t+  | Len_Sizet                 -- z+  | Len_NoMod                 -- <<no length modifier>>+ deriving (Eq,Ord,Show)++data Case+  = UpperCase+  | LowerCase+ deriving (Eq,Ord,Show)++data IntFormat+  = IntFormat_SignedDecimal      -- i,d+  | IntFormat_UnsignedDecimal    -- u+  | IntFormat_Octal              -- o+  | IntFormat_Hex Case           -- x,X+ deriving (Eq,Ord,Show)++signedIntFormat :: IntFormat -> Bool+signedIntFormat IntFormat_SignedDecimal = True+signedIntFormat _ = False++data FloatFormat+  = FloatFormat_Scientific Case -- e,E+  | FloatFormat_Standard Case   -- f,F+  | FloatFormat_Auto Case       -- g,G+  | FloatFormat_Hex Case        -- a,A+ deriving (Eq,Ord,Show)++data PrintfConversionType+  = Conversion_Integer  IntFormat+  | Conversion_Floating FloatFormat+  | Conversion_Char             -- c+  | Conversion_String           -- s+  | Conversion_Pointer          -- p+  | Conversion_CountChars       -- n+ deriving (Eq,Ord,Show)++data PrintfDirective+  = StringDirective BS.ByteString+  | ConversionDirective ConversionDirective+ deriving (Eq,Ord,Show)++data ConversionDirective = Conversion+    { printfAccessField :: Maybe Int+    , printfFlags     :: Set PrintfFlag+    , printfMinWidth  :: Int+    , printfPrecision :: Maybe Int+    , printfLengthMod :: PrintfLengthModifier+    , printfType      :: PrintfConversionType+    }+ deriving (Eq,Ord,Show)+++data PrintfOperations m+  = PrintfOperations+    { printfGetInteger  :: Int  -- Field number+                        -> Bool -- is Signed?+                        -> PrintfLengthModifier+                        -> m (Maybe Integer)+    , printfGetFloat    :: Int -- FieldNumber+                        -> PrintfLengthModifier+                        -> m (Maybe Rational)+    , printfGetPointer  :: Int -- FieldNumber+                        -> m String+    , printfGetString   :: Int -- FieldNumber+                        -> Maybe Int -- Number of chars to read; if Nothing, read until null terminator+                        -> m [Word8]+    , printfSetInteger  :: Int -- FieldNumber+                        -> PrintfLengthModifier+                        -> Int -- value to set+                        -> m ()++    , printfUnsupported :: !(forall a. GHC.HasCallStack => String -> m a)+    }++formatInteger+  :: Maybe Integer+  -> IntFormat+  -> Int -- min width+  -> Maybe Int -- precision+  -> Set PrintfFlag+  -> String+formatInteger mi fmt minwidth prec flags =+  case mi of+    Nothing ->+      let n = max 4 (max minwidth (fromMaybe 0 prec))+       in replicate n '?'+    Just i  -> do+      case fmt of+        IntFormat_SignedDecimal ->+           formatSignedDec i minwidth prec flags+        IntFormat_UnsignedDecimal ->+           formatUnsignedDec i minwidth prec flags+        IntFormat_Octal ->+           formatOctal i minwidth prec flags+        IntFormat_Hex c ->+           formatHex i c minwidth prec flags++insertThousands :: Char -> String -> String+insertThousands sep = reverse . go . reverse+ where+  go (a:b:c:xs@(_:_)) = a:b:c:sep:go xs+  go xs = xs+++addLeadingZeros ::+  Maybe Int -> -- precision+  String ->+  String+addLeadingZeros Nothing digits = digits+addLeadingZeros (Just p) digits =+   let n = max 0 (p - length digits) in+   replicate n '0' ++ digits++formatSignedDec+  :: Integer -- value to format+  -> Int     -- minwidth+  -> Maybe Int     -- precision+  -> Set PrintfFlag+  -> String+formatSignedDec i minwidth prec flags = do+  let sgn = if | i < 0  -> "-"+               | Set.member PrintfPosPlus  flags -> "+"+               | Set.member PrintfPosSpace flags -> " "+               | otherwise -> ""+  let digits = N.showInt (abs i) []+  let precdigits = addLeadingZeros prec digits+  let sepdigits = if Set.member PrintfThousandsSep flags then+                      insertThousands ',' precdigits -- FIXME, get thousands separator from somewhere?+                  else+                      precdigits+  let pad = max 0 (minwidth - length sepdigits - length sgn)+  if | Set.member PrintfNegativeWidth flags ->+          sgn ++ sepdigits ++ replicate pad ' '+     | Set.member PrintfZeroPadding flags && prec == Nothing ->+          -- FIXME? this interacts poorly with the thousands seperation flag...+          sgn ++ replicate pad '0' ++ sepdigits+     | otherwise ->+          replicate pad ' ' ++ sgn ++ sepdigits++formatUnsignedDec+  :: Integer -- value to format+  -> Int     -- minwidth+  -> Maybe Int     -- precision+  -> Set PrintfFlag+  -> String+formatUnsignedDec i minwidth prec flags = do+  let digits = N.showInt (abs i) []+  let precdigits = addLeadingZeros prec digits+  let sepdigits = if Set.member PrintfThousandsSep flags then+                      insertThousands ',' precdigits -- FIXME, get thousands separator from somewhere?+                  else+                      precdigits+  let pad = max 0 (minwidth - length sepdigits)+  if | Set.member PrintfNegativeWidth flags ->+          sepdigits ++ replicate pad ' '+     | Set.member PrintfZeroPadding flags && prec == Nothing ->+          -- FIXME? this interacts poorly with the thousands seperation flag...+          replicate pad '0' ++ sepdigits+     | otherwise ->+          replicate pad ' ' ++ sepdigits++formatOctal+  :: Integer -- value to format+  -> Int     -- minwidth+  -> Maybe Int     -- precision+  -> Set PrintfFlag+  -> String+formatOctal i minwidth prec flags = do+  let digits = N.showOct (abs i) []+  let precdigits = addLeadingZeros prec digits+  let altdigits = if Set.member PrintfAlternateForm flags && head precdigits /= '0' then+                     '0':precdigits+                  else+                     precdigits+  let pad = max 0 (minwidth - length altdigits)+  if | Set.member PrintfNegativeWidth flags ->+          altdigits ++ replicate pad ' '+     | Set.member PrintfZeroPadding flags && prec == Nothing ->+          replicate pad '0' ++ altdigits+     | otherwise ->+          replicate pad ' ' ++ altdigits++formatHex+  :: Integer -- value to format+  -> Case    -- upper or lower case+  -> Int     -- minwidth+  -> Maybe Int     -- precision+  -> Set PrintfFlag+  -> String+formatHex i c minwidth prec flags = do+  let digits = N.showHex (abs i) []+  let precdigits = addLeadingZeros prec digits+  -- Why only add "0x" when i is non-zero?  I have no idea,+  -- that's just what the docs say...+  let altstring = if Set.member PrintfAlternateForm flags && i /= 0 then+                    "0x"+                  else+                    ""+  let pad = max 0 (minwidth - length precdigits - length altstring)+  let padded = if | Set.member PrintfNegativeWidth flags ->+                       altstring ++ precdigits ++ replicate pad ' '+                  | Set.member PrintfZeroPadding flags && prec == Nothing ->+                       altstring ++ replicate pad '0' ++ precdigits+                  | otherwise ->+                       replicate pad ' ' ++ altstring ++ precdigits+  case c of+    UpperCase -> map toUpper padded+    LowerCase -> padded+++formatRational+  :: Maybe Rational+  -> FloatFormat+  -> Int -- min width+  -> Maybe Int -- precision+  -> Set PrintfFlag+  -> Either String String   -- ^ Left indicates an error, right is OK+formatRational mr fmt minwidth prec flags =+  case mr of+    Nothing ->+      let n = max 4 (min minwidth (fromMaybe 0 prec))+       in return (replicate n '?')+    Just r ->+      -- FIXME, we ignore the thousands flag...+      do let toCase c x = case c of+                            UpperCase -> map toUpper x+                            LowerCase -> x+         let sgn = if | r < 0  -> "-"+                      | Set.member PrintfPosPlus  flags -> "+"+                      | Set.member PrintfPosSpace flags -> " "+                      | otherwise -> ""+         let dbl = N.fromRat (abs r) :: Double+         let prec' = case prec of Nothing -> Just 6; _ -> prec+         str <- case fmt of+                  FloatFormat_Scientific c ->+                       return $ toCase c $ N.showEFloat prec' dbl []+                  FloatFormat_Standard c ->+                   return $ toCase c $+                     if Set.member PrintfAlternateForm flags+                       then N.showFFloatAlt prec' dbl []+                       else N.showFFloat prec' dbl []+                  FloatFormat_Auto c ->+                    return $ toCase c $+                      if Set.member PrintfAlternateForm flags+                         then N.showGFloatAlt prec' dbl []+                         else N.showGFloat prec' dbl []+                  FloatFormat_Hex _c ->+                    -- FIXME, could probably implement this using N.floatToDigits...+                    Left "'a' and 'A' conversion codes not currently supported"+         let pad = max 0 (minwidth - length str - length sgn)+         return $+           if | Set.member PrintfNegativeWidth flags ->+                  sgn ++ str ++ replicate pad ' '+              | Set.member PrintfZeroPadding flags ->+                   sgn ++ replicate pad '0' ++ str+              | otherwise ->+                   replicate pad ' ' ++ sgn ++ str++-- | Given a list of 'PrintfDirective's, compute the resulting 'BS.ByteString'+-- and its length.+--+-- We make an effort not to assume a particular text encoding for the+-- 'BS.ByteString' that this returns. Some parts of the implementation do use+-- functionality from "Data.ByteString.Char8", which is limited to the subset+-- of Unicode covered by code points 0-255. We believe these uses are justified,+-- however, and we have left comments explaining the reasoning behind each use.+executeDirectives :: forall m. Monad m+                  => PrintfOperations m+                  -> [PrintfDirective]+                  -> m (BS.ByteString, Int)+executeDirectives ops = go id 0 0+  where+   go :: (BS.ByteString -> BS.ByteString) -> Int -> Int -> [PrintfDirective] -> m (BS.ByteString, Int)+   go fstr !len !_fld [] = return (fstr BS.empty, len)+   go fstr !len !fld ((StringDirective s):xs) = do+       let len'  = len + BS.length s+       let fstr' = fstr . BS.append s+       go fstr' len' fld xs+   go fstr !len !fld (ConversionDirective d:xs) =+       let fld' = fromMaybe (fld+1) (printfAccessField d) in+       case printfType d of+         Conversion_Integer fmt -> do+           let sgn = signedIntFormat fmt+           i <- printfGetInteger ops fld' sgn (printfLengthMod d)+           -- The use of BSC.pack is fine here, as the output of formatInteger+           -- consists solely of ASCII characters.+           let istr  = BSC.pack $ formatInteger i fmt (printfMinWidth d) (printfPrecision d) (printfFlags d)+           let len'  = len + BS.length istr+           let fstr' = fstr . BS.append istr+           go fstr' len' fld' xs+         Conversion_Floating fmt -> do+           r <- printfGetFloat ops fld' (printfLengthMod d)+           -- The use of BSC.pack is fine here, as the output of formatRational+           -- consists solely of ASCII characters.+           rstr <- BSC.pack <$>+                   case formatRational r fmt+                           (printfMinWidth d)+                           (printfPrecision d)+                           (printfFlags d) of+                     Left err -> printfUnsupported ops err+                     Right a -> return a+           let len'  = len + BS.length rstr+           let fstr' = fstr . BS.append rstr+           go fstr' len' fld' xs+         Conversion_String -> do+           s <- BS.pack <$> printfGetString ops fld' (printfPrecision d)+           let len'  = len + BS.length s+           let fstr' = fstr . BS.append s+           go fstr' len' fld' xs+         Conversion_Char -> do+           let sgn  = False -- unsigned+           i <- printfGetInteger ops fld' sgn Len_NoMod+           let c :: Char = maybe '?' (toEnum . fromInteger) i+           let len'  = len + 1+           -- Note the use of BSC.cons here: this assumes on the assumption+           -- that C strings are arrays of 1-byte characters.+           let fstr' = fstr . BSC.cons c+           go fstr' len' fld' xs+         Conversion_Pointer -> do+           -- Note the use of BSC.pack here: this assumes that the output of+           -- printfGetPointer uses solely ASCII characters. For crux-llvm's+           -- printf override, this is always the case, as pointers are+           -- pretty-printed using the ppPtr function, which satisfies this+           -- criterion.+           pstr <- BSC.pack <$> printfGetPointer ops fld'+           let len'  = len + BS.length pstr+           let fstr' = fstr . BS.append pstr+           go fstr' len' fld' xs+         Conversion_CountChars -> do+           printfSetInteger ops fld' (printfLengthMod d) len+           go fstr len fld' xs++parseDirectives :: [Word8] -> Either String [PrintfDirective]+parseDirectives xs =+  parseOnly (parseFormatString <* endOfInput) (BS.pack xs)++parseFormatString :: Parser [PrintfDirective]+parseFormatString = many $ choice+  [ StringDirective <$> takeWhile1 (/= '%')+  , string "%%" >> return (StringDirective "%")+  , parseConversion+  ]++parseConversion :: Parser PrintfDirective+parseConversion = do+  _ <- char '%'+  field <- option Nothing (Just <$>+             do d <- decimal+                _ <- char '$'+                return d)+  flags <- parseFlags Set.empty+  width <- option 0 decimal+  prec  <- option Nothing (char '.' >> (Just <$> decimal))+  len   <- parseLenModifier+  typ   <- parseConversionType+  return $ ConversionDirective $ Conversion+         { printfAccessField = field+         , printfFlags       = flags+         , printfMinWidth    = width+         , printfPrecision   = prec+         , printfLengthMod   = len+         , printfType        = typ+         }++parseFlags :: Set PrintfFlag -> Parser (Set PrintfFlag)+parseFlags fs = choice+  [ char '#'  >> parseFlags (Set.insert PrintfAlternateForm fs)+  , char '0'  >> parseFlags (Set.insert PrintfZeroPadding fs)+  , char '-'  >> parseFlags (Set.insert PrintfNegativeWidth fs)+  , char ' '  >> parseFlags (Set.insert PrintfPosSpace fs)+  , char '+'  >> parseFlags (Set.insert PrintfPosPlus fs)+  , char '\'' >> parseFlags (Set.insert PrintfThousandsSep fs)+  , return fs+  ]++parseLenModifier :: Parser PrintfLengthModifier+parseLenModifier = choice+  [ string "hh" >> return Len_Byte+  , string "h"  >> return Len_Short+  , string "ll" >> return Len_LongLong+  , string "L"  >> return Len_LongDouble+  , string "l"  >> return Len_Long+  , string "j"  >> return Len_IntMax+  , string "t"  >> return Len_PtrDiff+  , string "z"  >> return Len_Sizet+  , return Len_NoMod+  ]++parseConversionType :: Parser PrintfConversionType+parseConversionType = choice+  [ char 'd' >> return (Conversion_Integer IntFormat_SignedDecimal)+  , char 'i' >> return (Conversion_Integer IntFormat_SignedDecimal)+  , char 'u' >> return (Conversion_Integer IntFormat_UnsignedDecimal)+  , char 'o' >> return (Conversion_Integer IntFormat_Octal)+  , char 'x' >> return (Conversion_Integer (IntFormat_Hex LowerCase))+  , char 'X' >> return (Conversion_Integer (IntFormat_Hex UpperCase))+  , char 'e' >> return (Conversion_Floating (FloatFormat_Scientific LowerCase))+  , char 'E' >> return (Conversion_Floating (FloatFormat_Scientific UpperCase))+  , char 'f' >> return (Conversion_Floating (FloatFormat_Standard LowerCase))+  , char 'F' >> return (Conversion_Floating (FloatFormat_Standard UpperCase))+  , char 'g' >> return (Conversion_Floating (FloatFormat_Auto LowerCase))+  , char 'G' >> return (Conversion_Floating (FloatFormat_Auto UpperCase))+  , char 'a' >> return (Conversion_Floating (FloatFormat_Hex LowerCase))+  , char 'A' >> return (Conversion_Floating (FloatFormat_Hex UpperCase))+  , char 'c' >> return Conversion_Char+  , char 's' >> return Conversion_String+  , char 'p' >> return Conversion_Pointer+  , char 'n' >> return Conversion_CountChars+  ]
+ src/Lang/Crucible/LLVM/QQ.hs view
@@ -0,0 +1,384 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.QQ+-- Description      : QuasiQuoters for a subset of LLVM assembly syntax+-- Copyright        : (c) Galois, Inc 2019+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Lang.Crucible.LLVM.QQ+ ( llvmType+ , llvmDecl+ , llvmOvr+ ) where++import Control.Monad (void)+import qualified Data.Attoparsec.Text as AT+import Data.Char+import Data.Data+import Data.Int+import qualified Data.Text as T+import qualified Text.LLVM.AST as L++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import qualified Data.Parameterized.Context as Ctx+import           Lang.Crucible.Types+import qualified Lang.Crucible.LLVM.Intrinsics.Common as IC+import           Lang.Crucible.LLVM.Types++-- | This type closely mirrors the type syntax from llvm-pretty,+--   but adds several additional constructors to represent+--   quasiquoter metavariables.+data QQType+  = QQVar String     -- ^ This constructor represents a type metavariable, e.g. @$var@+  | QQIntVar String  -- ^ This constructor represents a integer type metavariable, e.g. @#var@+  | QQSizeT          -- ^ This constructor represents an integer type that is the same width as a pointer+  | QQSSizeT          -- ^ This constructor represents a signed integer type that is the same width as a pointer+  | QQPrim L.PrimType+  | QQPtrTo QQType+  | QQPtrOpaque+  | QQAlias L.Ident+  | QQArray Int32 QQType+  | QQFunTy QQType [QQType] Bool+  | QQStruct [QQType]+  | QQPackedStruct [QQType]+  | QQVector Int32 QQType+  | QQOpaque+ deriving (Show, Eq, Ord, Data)++-- | This type closely mirrors the function declaration syntax from llvm-pretty,+--   except that the types and the name of the declaration may be metavarables.+data QQDeclare =+  QQDeclare+  { qqDecRet     :: QQType+  , qqDecName    :: Either String L.Symbol -- ^ a @Left@ value is a metavariable; @Right@ is a symbol+  , qqDecArgs    :: [QQType]+  , qqDecVarArgs :: Bool+  }+ deriving (Show, Eq, Ord, Data)++parseIdent :: AT.Parser L.Ident+parseIdent = L.Ident <$> (AT.char '%' *> AT.choice+  [ T.unpack <$> AT.takeWhile1 isDigit+  , (:) <$> AT.satisfy (AT.inClass "-a-zA-Z$._")+        <*> (T.unpack <$> (AT.takeWhile (AT.inClass "-a-zA-Z$._0-9")))+  ])+++parseSymbol :: AT.Parser L.Symbol+parseSymbol = L.Symbol <$> (AT.char '@' *>+  ( (:) <$> AT.satisfy (AT.inClass "-a-zA-Z$._")+        <*> (T.unpack <$> (AT.takeWhile (AT.inClass "-a-zA-Z$._0-9")))+  ))++parseFloatType :: AT.Parser L.FloatType+parseFloatType = AT.choice+  [ pure L.Half      <* AT.string "half"+  , pure L.Float     <* AT.string "float"+  , pure L.Double    <* AT.string "double"+  , pure L.Fp128     <* AT.string "fp128"+  , pure L.X86_fp80  <* AT.string "x86_fp80"+  , pure L.PPC_fp128 <* AT.string "ppc_fp128"+  ]++parsePrimType :: AT.Parser L.PrimType+parsePrimType = AT.choice+  [ pure L.Label    <* AT.string "label"+  , pure L.Void     <* AT.string "void"+  , pure L.Metadata <* AT.string "metadata"+  , pure L.X86mmx   <* AT.string "x86_mmx"+  , L.Integer <$> (AT.char 'i' *> AT.decimal)+  , L.FloatType <$> parseFloatType+  ]++parseSeqType ::+  Char ->+  Char ->+  (Int32 -> QQType -> QQType) ->+  AT.Parser QQType+parseSeqType start end cnstr =+  do void $ AT.char start+     AT.skipSpace+     n <- AT.decimal+     AT.skipSpace+     void $ AT.char 'x'+     AT.skipSpace+     tp <- parseType+     AT.skipSpace+     void $ AT.char end+     return $! cnstr n tp++parseCommaSeparatedTypes :: AT.Parser [QQType]+parseCommaSeparatedTypes = AT.choice+  [ do AT.skipSpace+       f  <- parseType+       fs <- AT.many' (AT.skipSpace *> AT.char ',' *> AT.skipSpace *> parseType)+       return (f:fs)+  , return []+  ]++parseStructType :: AT.Parser QQType+parseStructType =+  do void $ AT.char '{'+     fs <- parseCommaSeparatedTypes+     AT.skipSpace+     void $ AT.char '}'+     return $ QQStruct fs++parsePackedStructType :: AT.Parser QQType+parsePackedStructType =+  do void $ AT.string "<{"+     fs <- parseCommaSeparatedTypes+     AT.skipSpace+     void $ AT.string "}>"+     return $ QQPackedStruct fs++parseArgList :: AT.Parser ([QQType], Bool)+parseArgList =+  do void $ AT.char '('+     tps <- parseCommaSeparatedTypes+     AT.skipSpace+     varargs <- AT.choice+                [ do void $ AT.char ','+                     AT.skipSpace+                     void $ AT.string "..."+                     AT.skipSpace+                     void $ AT.char ')'+                     return True+                , do void $ AT.char ')'+                     return False+                ]+     return (tps, varargs)++parseVar :: AT.Parser String+parseVar = T.unpack <$> (AT.char '$' *> AT.takeWhile1 varChar)+ where+ varChar c = isAlpha c || isDigit c || c == '\'' || c == '_'++parseIntVar :: AT.Parser String+parseIntVar = T.unpack <$> (AT.char '#' *> AT.takeWhile1 varChar)+ where+ varChar c = isAlpha c || isDigit c || c == '\'' || c == '_'++parseType :: AT.Parser QQType+parseType =+  do base <- AT.choice+             [ parseSeqType '<' '>' QQVector+             , parseSeqType '[' ']' QQArray+             , parseStructType+             , parsePackedStructType+             , QQVar <$> parseVar+             , QQIntVar <$> parseIntVar+             , QQAlias <$> parseIdent+             , QQPrim <$> parsePrimType+             , pure QQOpaque <* AT.string "opaque"+             , pure QQSizeT  <* AT.string "size_t"+             , pure QQSSizeT  <* AT.string "ssize_t"+             , pure QQPtrOpaque <* AT.string "ptr"+             ]+     base' <- AT.choice+              [ do AT.skipSpace+                   (args,varargs) <- parseArgList+                   return (QQFunTy base args varargs)+              , return base+              ]+     parseStars base'++  where+  parseStars x =+    AT.choice+    [ do AT.skipSpace+         void $ AT.char '*'+         parseStars (QQPtrTo x)+    , return x+    ]++parseDeclare :: AT.Parser QQDeclare+parseDeclare =+  do AT.skipSpace+     ret <- parseType+     AT.skipSpace+     sym <- AT.eitherP parseVar parseSymbol+     AT.skipSpace+     (args, varargs) <- parseArgList+     AT.skipSpace+     return+       QQDeclare+       { qqDecRet     = ret+       , qqDecName    = sym+       , qqDecArgs    = args+       , qqDecVarArgs = varargs+       }+++liftQQType :: QQType -> Q Exp+liftQQType tp =+  case tp of+    QQVar nm     -> varE (mkName nm)+    QQIntVar nm  -> [| L.PrimType (L.Integer (fromInteger (intValue $(varE (mkName nm)) ))) |]+    QQSizeT      -> varE 'IC.llvmSizeT+    QQSSizeT      -> varE 'IC.llvmSSizeT+    QQAlias nm   -> [| L.Alias nm |]+    QQPrim pt    -> [| L.PrimType pt |]+    QQPtrTo t    -> [| L.PtrTo $(liftQQType t) |]+    QQPtrOpaque  -> [| L.PtrOpaque |]+    QQArray n t  -> [| L.Array n $(liftQQType t) |]+    QQVector n t -> [| L.Vector n $(liftQQType t) |]+    QQStruct ts  -> [| L.Struct $(listE (map liftQQType ts)) |]+    QQPackedStruct ts -> [| L.PackedStruct $(listE (map liftQQType ts)) |]+    QQOpaque -> [| L.Opaque |]+    QQFunTy ret args varargs -> [| L.FunTy $(liftQQType ret) $(listE (map liftQQType args)) $(lift varargs) |]++liftQQDecl :: QQDeclare -> Q Exp+liftQQDecl (QQDeclare ret nm args varargs) =+   [| L.Declare+      { L.decLinkage    = Nothing+      , L.decVisibility = Nothing+      , L.decRetType    = $(liftQQType ret)+      , L.decName       = $(f nm)+      , L.decArgs       = $(listE (map liftQQType args))+      , L.decVarArgs    = $(lift varargs)+      , L.decAttrs      = []+      , L.decComdat     = Nothing+      }+    |]+  where+  f (Left v)    = varE (mkName v)+  f (Right sym) = lift sym++liftKnownNat :: Integral a => a -> Q Exp+liftKnownNat n = [| knownNat @($(litT (numTyLit (toInteger n)))) |]++liftTypeRepr :: QQType -> Q Exp+liftTypeRepr t = case t of+    QQVar nm      -> varE (mkName (nm++"_repr"))+    QQIntVar nm   -> [| BVRepr $(varE (mkName nm)) |]+    QQSizeT       -> [| SizeT |]+    QQSSizeT      -> [| SSizeT |]+    QQPrim pt     -> liftPrim pt+    QQPtrTo _t    -> [| PtrRepr |]+    QQPtrOpaque   -> [| PtrRepr |]+    QQArray _ t'  -> [| VectorRepr $(liftTypeRepr t') |]+    QQVector _ t' -> [| VectorRepr $(liftTypeRepr t') |]+    QQStruct ts   -> [| StructRepr $(liftArgs ts False) |]+    QQPackedStruct ts -> [| StructRepr $(liftArgs ts False) |]+    QQAlias{} -> fail "Cannot lift alias type to repr"+    QQOpaque  -> fail "Cannot lift opaque type to repr"+    QQFunTy{} -> fail "Cannot lift function type to repr"+ where+  liftPrim pt = case pt of+    L.Void         -> [| UnitRepr |]+    L.Integer n    -> [| BVRepr $(liftKnownNat n) |]+    L.FloatType ft -> [| FloatRepr $(liftFloatType ft) |]+    L.Label    -> fail "Cannot lift label type to repr"+    L.X86mmx   -> fail "Cannot lift X86mmx type to repr"+    L.Metadata -> fail "Cannot lift metatata type to repr"++  liftFloatType ft = case ft of+    L.Half      -> [| HalfFloatRepr |]+    L.Float     -> [| SingleFloatRepr |]+    L.Double    -> [| DoubleFloatRepr |]+    L.Fp128     -> [| QuadFloatRepr |]+    L.X86_fp80  -> [| X86_80FloatRepr |]+    L.PPC_fp128 -> [| DoubleDoubleFloatRepr|]++liftArgs :: [QQType] -> Bool -> Q Exp+liftArgs = go [| Ctx.Empty |]+ where+ go :: Q Exp -> [QQType] -> Bool -> Q Exp+ go xs [] True  = [| $(xs) Ctx.:> VectorRepr AnyRepr |]+ go xs [] False = xs+ go xs (t:ts) varargs = go [| $(xs) Ctx.:> $(liftTypeRepr t) |] ts varargs+++liftQQDeclToOverride :: QQDeclare -> Q Exp+liftQQDeclToOverride qqd@(QQDeclare ret _nm args varargs) =+  [| IC.LLVMOverride $(liftQQDecl qqd) $(liftArgs args varargs) $(liftTypeRepr ret) |]++-- | This quasiquoter parses values in LLVM type syntax, extended+--   with metavariables, and builds values of @Text.LLVM.AST.Type@.+--+--   Type metavariables start with a @$@ and splice in the named+--   program variable, which is expected to have type @Type@.+--+--   Numeric metavariables start with @#@ and splice in an integer+--   type whose width is given by the named program variable, which+--   is expected to be a @NatRepr@.+llvmType :: QuasiQuoter+llvmType =+  QuasiQuoter+  { quoteExp = \str ->+       do case AT.parseOnly parseType (T.pack str) of+            Left msg -> error msg+            Right x  -> liftQQType x++  , quotePat = error "llvmType cannot quasiquote a pattern"+  , quoteType = error "llvmType cannot quasiquote a Haskell type"+  , quoteDec = error "llvmType cannot quasiquote a declaration"+  }++-- | This quasiquoter parses values in LLVM function declaration syntax,+--   extended with metavariables, and builds values of @Text.LLVM.AST.Declare@.+--+--   Type metavariables start with a @$@ and splice in the named+--   program variable, which is expected to have type @Type@.+--+--   Numeric metavariables start with @#@ and splice in an integer+--   type whose width is given by the named program variable, which+--   is expected to be a @NatRepr@.+--+--   The name of the declaration may also be a @$@ metavariable, in which+--   case the named variable is expeted to be a @Symbol@.+llvmDecl :: QuasiQuoter+llvmDecl =+  QuasiQuoter+  { quoteExp = \str ->+       do case AT.parseOnly parseDeclare (T.pack str) of+            Left msg -> error msg+            Right x  -> liftQQDecl x++  , quotePat = error "llvmDecl cannot quasiquote a pattern"+  , quoteType = error "llvmDecl cannot quasiquote a Haskell type"+  , quoteDec = error "llvmDecl cannot quasiquote a declaration"+  }++-- | This quasiquoter parses values in LLVM function declaration syntax,+--   extended with metavariables, and partially applies the+--   @LLVMOverride@ constructor so that it expectes a single remaining+--   argument to populate the @llvmOverride_def@ field.+--+--   Type metavariables start with a @$@ and splice in the named+--   program variable, which is expected to have type @Type@.+--   In addition a related variable must be in scope to give the+--   crucible @TypeRepr@ associated.  For example variable @$x@+--   should be a LLVM @Type@ and @$x_repr@ should be a Crucible @TypeRepr@.+--+--   Numeric metavariables start with @#@ and splice in an integer+--   type whose width is given by the named program variable, which+--   is expected to be a @NatRepr@.  Both the LLVM type and the Crucible+--   @TypeRepr@ are built from the @NatRepr@.+--+--   The name of the declaration may also be a @$@ metavariable, in which+--   case the named variable is expeted to be a @Symbol@.+llvmOvr :: QuasiQuoter+llvmOvr =+  QuasiQuoter+  { quoteExp = \str ->+       do case AT.parseOnly parseDeclare (T.pack str) of+            Left msg -> error msg+            Right x  -> liftQQDeclToOverride x++  , quotePat = error "llvmOvr cannot quasiquote a pattern"+  , quoteType = error "llvmOvr cannot quasiquote a Haskell type"+  , quoteDec = error "llvmOvr cannot quasiquote a declaration"+  }
+ src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs view
@@ -0,0 +1,892 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.SimpleLoopFixpoint+-- Description      : Execution feature to compute loop fixpoint+-- Copyright        : (c) Galois, Inc 2021+-- License          : BSD3+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++module Lang.Crucible.LLVM.SimpleLoopFixpoint+  ( FixpointEntry(..)+  , simpleLoopFixpoint+  ) where++import           Control.Lens+import           Control.Monad (when)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Reader (ReaderT(..))+import           Control.Monad.State (MonadState(..), StateT(..))+import           Control.Monad.Trans.Maybe+import           Data.Either+import           Data.Foldable+import qualified Data.IntMap as IntMap+import           Data.IORef+import qualified Data.List as List+import           Data.Maybe+import qualified Data.Map as Map+import           Data.Map (Map)+import qualified Data.Set as Set+import qualified System.IO+import           Numeric.Natural++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.TraversableF+import           Data.Parameterized.TraversableFC++import qualified What4.Config as W4+import qualified What4.Interface 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.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+++-- | 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 varible, 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+  { headerValue :: W4.SymExpr sym tp+  , bodyValue :: W4.SymExpr sym tp+  }++instance OrdF (W4.SymExpr sym) => OrdF (FixpointEntry sym) where+  compareF x y = case compareF (headerValue x) (headerValue y) of+    LTF -> LTF+    EQF -> compareF (bodyValue x) (bodyValue y)+    GTF -> GTF++instance OrdF (FixpointEntry sym) => W4.TestEquality (FixpointEntry sym) where+  testEquality x y = case compareF x y of+    EQF -> Just Refl+    _ -> Nothing++data MemFixpointEntry sym = forall w . (1 <= w) => MemFixpointEntry+  { memFixpointEntrySym :: sym+  , memFixpointEntryJoinVariable :: W4.SymBV sym w+  }++-- | This datatype captures the state machine that progresses as we+--   attempt to compute a loop invariant for a simple structured loop.+data FixpointState sym blocks+    -- | 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 blocks)++    -- | 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 blocks)+      (LoopIndexBound sym) -- ^ data about the fixed sort of loop index values we are trying to find++    -- | 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 blocks)+      (LoopIndexBound sym) -- ^ data about the fixed sort of loop index values we are trying to find++-- | Data about the loop that we incrementally compute as we approach fixpoint.+data FixpointRecord sym blocks = forall args.+  FixpointRecord+  {+    -- | Block identifier of the head of the loop+    fixpointBlockId :: C.Some (C.BlockID blocks)++    -- | identifier for the currently-active assumption frame related to this fixpoint computation+  , 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.+  , fixpointSubstitution :: MapF (W4.SymExpr sym) (FixpointEntry sym)++    -- | Prestate values of the Crucible registers when the loop header is first encountered.+  , fixpointRegMap :: C.RegMap sym args++    -- | Triples are (blockId, offset, size) to bitvector-typed entries ( bitvector only/not pointers )+  , fixpointMemSubstitution :: Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType)++    -- | Condition which, when true, stays in the loop. This is captured when the (unique, by assumption)+    --   symbolic branch that exits the loop is encountered. This condition is updated on each iteration+    --   as we widen the invariant.+  , fixpointLoopCondition :: Maybe (W4.Pred sym)+  }+++fixpointRecord :: FixpointState sym blocks -> Maybe (FixpointRecord sym blocks)+fixpointRecord BeforeFixpoint = Nothing+fixpointRecord (ComputeFixpoint r) = Just r+fixpointRecord (CheckFixpoint r _) = Just r+fixpointRecord (AfterFixpoint r _) = Just r+++type FixpointMonad sym = StateT (MapF (W4.SymExpr sym) (FixpointEntry sym)) IO+++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 sym = Ctx.zipWithM (joinRegEntry sym)++joinRegEntry ::+  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>+  sym ->+  C.RegEntry sym tp ->+  C.RegEntry sym tp ->+  FixpointMonad sym (C.RegEntry sym tp)+joinRegEntry sym left right = case C.regType left of+  C.LLVMPointerRepr w++      -- special handling for "don't care" registers coming from Macaw+    | List.isPrefixOf "cmacaw_reg" (show $ W4.printSymNat $ C.llvmPointerBlock (C.regValue left))+    , List.isPrefixOf "cmacaw_reg" (show $ W4.printSymExpr $ C.llvmPointerOffset (C.regValue left)) -> do+      liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: cmacaw_reg"+      return left++    | C.llvmPointerBlock (C.regValue left) == C.llvmPointerBlock (C.regValue right) -> do+      liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr"+      subst <- get+      if isJust (W4.testEquality (C.llvmPointerOffset (C.regValue left)) (C.llvmPointerOffset (C.regValue right)))+      then do+        liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: left == right"+        return left+      else case MapF.lookup (C.llvmPointerOffset (C.regValue left)) subst of+        Just join_entry -> do+          liftIO $ ?logMessage $+            "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Just: "+            ++ show (W4.printSymExpr $ bodyValue join_entry)+            ++ " -> "+            ++ show (W4.printSymExpr $ C.llvmPointerOffset (C.regValue right))+          put $ MapF.insert+            (C.llvmPointerOffset (C.regValue left))+            (join_entry { bodyValue = C.llvmPointerOffset (C.regValue right) })+            subst+          return left+        Nothing -> do+          liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Nothing"+          join_varaible <- liftIO $ W4.freshConstant sym (userSymbol' "reg_join_var") (W4.BaseBVRepr w)+          let join_entry = FixpointEntry+                { headerValue = C.llvmPointerOffset (C.regValue left)+                , bodyValue = C.llvmPointerOffset (C.regValue right)+                }+          put $ MapF.insert join_varaible join_entry subst+          return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) join_varaible+    | otherwise ->+      fail $+        "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: unsupported pointer base join: "+        ++ show (C.ppPtr $ C.regValue left)+        ++ " \\/ "+        ++ show (C.ppPtr $ C.regValue right)++  C.BoolRepr+    | List.isPrefixOf "cmacaw" (show $ W4.printSymExpr $ C.regValue left) -> do+      liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: cmacaw_reg"+      return left+    | otherwise -> do+      liftIO $ ?logMessage $+        "SimpleLoopFixpoint.joinRegEntry: BoolRepr:"+        ++ show (W4.printSymExpr $ C.regValue left)+        ++ " \\/ "+        ++ show (W4.printSymExpr $ C.regValue right)+      join_varaible <- liftIO $ W4.freshConstant sym (userSymbol' "macaw_reg") W4.BaseBoolRepr+      return $ C.RegEntry C.BoolRepr join_varaible++  C.StructRepr field_types -> do+    liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: StructRepr"+    C.RegEntry (C.regType left) <$> fmapFC (C.RV . C.regValue) <$> joinRegEntries sym+      (Ctx.generate (Ctx.size field_types) $ \i ->+        C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue left) Ctx.! i)+      (Ctx.generate (Ctx.size field_types) $ \i ->+        C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue right) Ctx.! i)+  _ -> fail $ "SimpleLoopFixpoint.joinRegEntry: unsupported type: " ++ show (C.regType 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 sym substitution = fmapFC (applySubstitutionRegEntry sym substitution)++applySubstitutionRegEntry ::+  C.IsSymInterface sym =>+  sym ->+  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->+  C.RegEntry sym tp ->+  C.RegEntry sym tp+applySubstitutionRegEntry sym substitution entry = case C.regType entry of+  C.LLVMPointerRepr{} ->+    entry+      { C.regValue = C.LLVMPointer+          (C.llvmPointerBlock (C.regValue entry))+          (MapF.findWithDefault+            (C.llvmPointerOffset (C.regValue entry))+            (C.llvmPointerOffset (C.regValue entry))+            substitution)+      }+  C.BoolRepr ->+    entry+  C.StructRepr field_types ->+    entry+      { C.regValue = fmapFC (C.RV . C.regValue) $+          applySubstitutionRegEntries sym substitution $+          Ctx.generate (Ctx.size field_types) $+          \i -> C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue entry) Ctx.! i+      }+  _ -> C.panic "SimpleLoopFixpoint.applySubstitutionRegEntry" ["unsupported type: " ++ show (C.regType entry)]+++findLoopIndex ::+  (?logMessage :: String -> IO (), C.IsSymInterface sym, C.HasPtrWidth wptr) =>+  sym ->+  MapF (W4.SymExpr sym) (FixpointEntry sym) ->+  IO (W4.SymBV sym wptr, Natural, Natural)+findLoopIndex sym substitution = do+  candidates <- catMaybes <$> mapM+    (\(MapF.Pair variable FixpointEntry{..}) -> case W4.testEquality (W4.BaseBVRepr ?ptrWidth) (W4.exprType variable) of+      Just Refl -> do+        diff <- liftIO $ W4.bvSub sym bodyValue variable+        case (BV.asNatural <$> W4.asBV headerValue, BV.asNatural <$> W4.asBV diff) of+          (Just start, Just step) -> do+            liftIO $ ?logMessage $+              "SimpleLoopFixpoint.findLoopIndex: " ++ show (W4.printSymExpr variable) ++ "=" ++ show (start, step)+            return $ Just (variable, start, step)+          _ -> return Nothing+      Nothing -> return Nothing)+    (MapF.toList substitution)+  case candidates of+    [candidate] -> return candidate+    _ -> fail "SimpleLoopFixpoint.findLoopIndex: loop index identification failure."++findLoopBound ::+  (C.IsSymInterface sym, C.HasPtrWidth wptr) =>+  sym ->+  W4.Pred sym ->+  Natural ->+  Natural ->+  IO (W4.SymBV sym wptr)+findLoopBound sym condition _start step =+  case Set.toList $ W4.exprUninterpConstants sym condition of++    -- this is a grungy hack, we are expecting exactly three variables and take the first+    [C.Some loop_stop, _, _]+      | Just Refl <- W4.testEquality (W4.BaseBVRepr ?ptrWidth) (W4.exprType $ W4.varExpr sym loop_stop) ->+        W4.bvMul sym (W4.varExpr sym loop_stop) =<< W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral step)+    _ -> fail "SimpleLoopFixpoint.findLoopBound: loop bound identification failure."+++-- index variable information for fixed stride, bounded loops+data LoopIndexBound sym = forall w . 1 <= w => LoopIndexBound+  { index :: W4.SymBV sym w+  , start :: Natural+  , stop :: W4.SymBV sym w+  , step :: Natural+  }++findLoopIndexBound ::+  (?logMessage :: String -> IO (), C.IsSymInterface sym, C.HasPtrWidth wptr) =>+  sym ->+  MapF (W4.SymExpr sym) (FixpointEntry sym) ->+  Maybe (W4.Pred sym) ->+  IO (LoopIndexBound sym)+findLoopIndexBound _sym _substitition Nothing =+  fail "findLoopIndexBound: no loop condition recorded!"++findLoopIndexBound sym substitution (Just condition) = do+  (loop_index, start, step) <- findLoopIndex sym substitution+  stop <- findLoopBound sym condition start step+  return $ LoopIndexBound+    { index = loop_index+    , start = start+    , stop = stop+    , step = step+    }++-- hard-coded here that we are always looking for a loop condition delimited by an unsigned comparison+loopIndexBoundCondition ::+  (C.IsSymInterface sym, 1 <= w) =>+  sym ->+  W4.SymBV sym w ->+  W4.SymBV sym w ->+  IO (W4.Pred sym)+loopIndexBoundCondition = W4.bvUlt++-- | Describes an assumed invariant on the loop index variable, which is that it is an offset+--   from the initial value that is a multiple of a discoveded stride value.+loopIndexStartStepCondition ::+  C.IsSymInterface sym =>+  sym ->+  LoopIndexBound sym ->+  IO (W4.Pred sym)+loopIndexStartStepCondition sym LoopIndexBound{ index = loop_index, start = start, step = step } = do+  start_bv <- W4.bvLit sym (W4.bvWidth loop_index) (BV.mkBV (W4.bvWidth loop_index) $ fromIntegral start)+  step_bv <- W4.bvLit sym (W4.bvWidth loop_index) (BV.mkBV (W4.bvWidth loop_index) $ fromIntegral step)+  W4.bvEq sym start_bv =<< W4.bvUrem sym loop_index step_bv+++loadMemJoinVariables ::+  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>+  bak ->+  C.MemImpl sym ->+  Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType) ->+  IO (MapF (W4.SymExpr sym) (W4.SymExpr sym))+loadMemJoinVariables bak mem subst =+  let sym = C.backendGetSym bak in+  MapF.fromList <$> mapM+    (\((blk, off, _sz), (MemFixpointEntry { memFixpointEntryJoinVariable = join_varaible }, storeage_type)) -> do+      ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral off)+      val <- C.doLoad bak mem ptr storeage_type (C.LLVMPointerRepr $ W4.bvWidth join_varaible) C.noAlignment+      case W4.asNat (C.llvmPointerBlock val) of+        Just 0 -> return $ MapF.Pair join_varaible $ C.llvmPointerOffset val+        _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" ++ show (C.ppPtr val))+    (Map.toAscList subst)++storeMemJoinVariables ::+  (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>+  bak ->+  C.MemImpl sym ->+  Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType) ->+  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->+  IO (C.MemImpl sym)+storeMemJoinVariables bak mem mem_subst eq_subst =+  let sym = C.backendGetSym bak in+  foldlM+  (\mem_acc ((blk, off, _sz), (MemFixpointEntry { memFixpointEntryJoinVariable = join_varaible }, storeage_type)) -> do+    ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral off)+    C.doStore bak mem_acc ptr (C.LLVMPointerRepr $ W4.bvWidth join_varaible) storeage_type C.noAlignment =<<+      C.llvmPointer_bv sym (MapF.findWithDefault join_varaible join_varaible eq_subst))+  mem+  (Map.toAscList mem_subst)++dropMemStackFrame :: C.IsSymInterface sym => C.MemImpl sym -> (C.MemImpl sym, C.MemAllocs sym, C.MemWrites sym)+dropMemStackFrame mem = case (C.memImplHeap mem) ^. C.memState of+  (C.StackFrame _ _ _ (a, w) s) -> ((mem { C.memImplHeap = (C.memImplHeap mem) & C.memState .~ s }), a, w)+  _ -> C.panic "SimpleLoopFixpoint.dropMemStackFrame" ["not a stack frame:", show (C.ppMem $ C.memImplHeap mem)]+++filterSubstitution ::+  C.IsSymInterface sym =>+  sym ->+  MapF (W4.SymExpr sym) (FixpointEntry sym) ->+  MapF (W4.SymExpr sym) (FixpointEntry sym)+filterSubstitution sym substitution =+  -- TODO: fixpoint+  let uninterp_constants = foldMapF+        (Set.map (C.mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . bodyValue)+        substitution+  in+  MapF.filterWithKey (\variable _entry -> Set.member (C.Some variable) uninterp_constants) substitution++-- find widening variables that are actually the same (up to syntactic equality)+-- and can be substituted for each other+uninterpretedConstantEqualitySubstitution ::+  forall sym .+  C.IsSymInterface sym =>+  sym ->+  MapF (W4.SymExpr sym) (FixpointEntry sym) ->+  (MapF (W4.SymExpr sym) (FixpointEntry sym), MapF (W4.SymExpr sym) (W4.SymExpr sym))+uninterpretedConstantEqualitySubstitution _sym substitution =+  let reverse_substitution = MapF.foldlWithKey'+        (\accumulator variable entry -> MapF.insert entry variable accumulator)+        MapF.empty+        substitution+      uninterpreted_constant_substitution = fmapF+        (\entry -> fromJust $ MapF.lookup entry reverse_substitution)+        substitution+      normal_substitution = MapF.filterWithKey+        (\variable _entry ->+          Just Refl == W4.testEquality variable (fromJust $ MapF.lookup variable uninterpreted_constant_substitution))+        substitution+  in+  (normal_substitution, uninterpreted_constant_substitution)+++userSymbol' :: String -> W4.SolverSymbol+userSymbol' = fromRight (C.panic "SimpleLoopFixpoint.userSymbol'" []) . W4.userSymbol+++-- | 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 limititations.+--   Most notibly, it only really works properly for functions+--   consiting 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 strucutre are not+--   checked.+--+--   The basic use case here is for verifiying 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 ::+  forall sym ext p rtp blocks init ret .+  (C.IsSymInterface sym, 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 -} ->+  (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), W4.Pred sym)) ->+  IO (C.ExecutionFeature p sym ext rtp)+simpleLoopFixpoint sym cfg@C.CFG{..} mem_var fixpoint_func = do+  let ?ptrWidth = knownNat @64++  verbSetting <- W4.getOptionSetting W4.verbosity $ W4.getConfiguration sym+  verb <- fromInteger <$> W4.getOpt verbSetting++  -- 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)++  fixpoint_state_ref <- newIORef @(FixpointState sym blocks) BeforeFixpoint++  return $ C.ExecutionFeature $ \exec_state -> do+    let ?logMessage = \msg -> when (verb >= (3 :: Natural)) $ do+          let h = C.printHandle $ C.execStateContext exec_state+          System.IO.hPutStrLn h msg+          System.IO.hFlush h+    fixpoint_state <- readIORef fixpoint_state_ref+    C.withBackend (C.execStateContext exec_state) $ \bak ->+     case exec_state of+      C.RunningState (C.RunBlockStart block_id) sim_state+        | C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)++        -- make sure the types match+        , Just Refl <- W4.testEquality+            (fmapFC C.blockInputs cfgBlockMap)+            (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)++          -- loop map is what we computed above, is this state at a loop header+        , Map.member (C.Some block_id) loop_map ->++            advanceFixpointState bak mem_var fixpoint_func block_id sim_state fixpoint_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 branch_condition true_frame false_frame _target sim_state+          | Just fixpoint_record <- fixpointRecord fixpoint_state+          , Just loop_body_some_block_ids <- Map.lookup (fixpointBlockId fixpoint_record) loop_map+          , JustPausedFrameTgtId true_frame_some_block_id <- pausedFrameTgtId true_frame+          , JustPausedFrameTgtId false_frame_some_block_id <- pausedFrameTgtId false_frame+          , C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)+          , Just Refl <- W4.testEquality+              (fmapFC C.blockInputs cfgBlockMap)+              (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)+          , elem true_frame_some_block_id loop_body_some_block_ids /= elem false_frame_some_block_id loop_body_some_block_ids -> do++            (loop_condition, inside_loop_frame, outside_loop_frame) <-+              if elem true_frame_some_block_id loop_body_some_block_ids+              then+                return (branch_condition, true_frame, false_frame)+              else do+                not_branch_condition <- W4.notPred sym branch_condition+                return (not_branch_condition, false_frame, true_frame)++            (condition, frame) <- case fixpoint_state of+              BeforeFixpoint -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint:" ["BeforeFixpoint"]++              ComputeFixpoint _fixpoint_record -> do+                -- continue in the loop+                ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: ComputeFixpoint"+                writeIORef fixpoint_state_ref $+                  ComputeFixpoint fixpoint_record { fixpointLoopCondition = Just loop_condition }+                return (loop_condition, inside_loop_frame)++              CheckFixpoint _fixpoint_record _loop_bound -> do+                -- continue in the loop+                ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: CheckFixpoint"+                return (loop_condition, inside_loop_frame)++              AfterFixpoint _fixpoint_record _loop_bound -> do+                -- break out of the loop+                ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: AfterFixpoint"+                not_loop_condition <- W4.notPred sym loop_condition+                return (not_loop_condition, outside_loop_frame)++            loc <- W4.getCurrentProgramLoc sym+            C.addAssumption bak $ C.BranchCondition loc (C.pausedLoc frame) condition+            C.ExecutionFeatureNewState <$>+              runReaderT+                (C.resumeFrame (C.forgetPostdomFrame frame) $ sim_state ^. (C.stateTree . C.actContext))+                sim_state++      _ -> return C.ExecutionFeatureNoChange+++advanceFixpointState ::+  forall sym bak ext p rtp blocks r args .+  (C.IsSymBackend sym bak, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) =>+  bak ->+  C.GlobalVar C.Mem ->+  (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), W4.Pred sym)) ->+  C.BlockID blocks args ->+  C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) ->+  FixpointState sym blocks ->+  IORef (FixpointState sym blocks) ->+  IO (C.ExecutionFeatureResult p sym ext rtp)++advanceFixpointState bak mem_var fixpoint_func block_id sim_state fixpoint_state fixpoint_state_ref =+  let ?ptrWidth = knownNat @64 in+  let sym = C.backendGetSym bak in+  case fixpoint_state of+    BeforeFixpoint -> do+      ?logMessage $ "SimpleLoopFixpoint: RunningState: BeforeFixpoint -> ComputeFixpoint"+      assumption_frame_identifier <- C.pushAssumptionFrame bak+      let mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals)+      let res_mem_impl = mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" $ C.memImplHeap mem_impl }+      writeIORef fixpoint_state_ref $ ComputeFixpoint $+        FixpointRecord+        { fixpointBlockId = C.Some block_id+        , fixpointAssumptionFrameIdentifier = assumption_frame_identifier+        , fixpointSubstitution = MapF.empty+        , fixpointRegMap = sim_state ^. (C.stateCrucibleFrame . C.frameRegs)+        , fixpointMemSubstitution = Map.empty+        , fixpointLoopCondition = Nothing -- we don't know the loop condition yet+        }+      return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+        sim_state & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++    ComputeFixpoint fixpoint_record+      | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record+      , Just Refl <- W4.testEquality+          (fmapFC C.regType $ C.regMap reg_map)+          (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do+++        ?logMessage $ "SimpleLoopFixpoint: RunningState: ComputeFixpoint: " ++ show block_id+        _ <- C.popAssumptionFrameAndObligations bak $ fixpointAssumptionFrameIdentifier fixpoint_record++        -- widen the inductive condition+        (join_reg_map, join_substitution) <- runStateT+          (joinRegEntries sym+            (C.regMap reg_map)+            (C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs))) $+          fixpointSubstitution fixpoint_record++        let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals)+        let (header_mem_impl, mem_allocs, mem_writes) = dropMemStackFrame body_mem_impl+        when (C.sizeMemAllocs mem_allocs /= 0) $+          fail "SimpleLoopFixpoint: unsupported memory allocation in loop body."++        -- widen the memory+        mem_substitution_candidate <- Map.fromList <$> catMaybes <$> case mem_writes of+          C.MemWrites [C.MemWritesChunkIndexed mmm] -> mapM+            (\case+              (C.MemWrite ptr (C.MemStore _ storeage_type _))+                | Just blk <- W4.asNat (C.llvmPointerBlock ptr)+                , Just off <- BV.asNatural <$> W4.asBV (C.llvmPointerOffset ptr) -> do+                  let sz = C.typeEnd 0 storeage_type+                  some_join_varaible <- liftIO $ case W4.mkNatRepr $ C.bytesToBits sz of+                    C.Some bv_width+                      | Just C.LeqProof <- W4.testLeq (W4.knownNat @1) bv_width -> do+                        join_varaible <- W4.freshConstant sym+                          (userSymbol' "mem_join_var")+                          (W4.BaseBVRepr bv_width)+                        return $ MemFixpointEntry+                          { memFixpointEntrySym = sym+                          , memFixpointEntryJoinVariable = join_varaible+                          }+                      | otherwise ->+                        C.panic+                          "SimpleLoopFixpoint.simpleLoopFixpoint"+                          ["unexpected storage type " ++ show storeage_type ++ " of size " ++ show sz]+                  return $ Just ((blk, off, fromIntegral sz), (some_join_varaible, storeage_type))+                | Just blk <- W4.asNat (C.llvmPointerBlock ptr)+                , Just Refl <- W4.testEquality ?ptrWidth (C.ptrWidth ptr) -> do+                  maybe_ranges <- runMaybeT $+                    C.writeRangesMem @_ @64 sym $ C.memImplHeap header_mem_impl+                  case maybe_ranges of+                    Just ranges -> do+                      sz <- W4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth $ toInteger $ C.typeEnd 0 storeage_type+                      forM_ (Map.findWithDefault [] blk ranges) $ \(prev_off, prev_sz) -> do+                        disjoint_pred <- C.buildDisjointRegionsAssertionWithSub+                          sym+                          ptr+                          sz+                          (C.LLVMPointer (C.llvmPointerBlock ptr) prev_off)+                          prev_sz+                        when (W4.asConstantPred disjoint_pred /= Just True) $+                          fail $+                            "SimpleLoopFixpoint: non-disjoint ranges: off1="+                            ++ show (W4.printSymExpr (C.llvmPointerOffset ptr))+                            ++ ", sz1="+                            ++ show (W4.printSymExpr sz)+                            ++ ", off2="+                            ++ show (W4.printSymExpr prev_off)+                            ++ ", sz2="+                            ++ show (W4.printSymExpr prev_sz)+                      return Nothing+                    Nothing -> fail $ "SimpleLoopFixpoint: unsupported symbolic pointers"+              _ -> fail $ "SimpleLoopFixpoint: not MemWrite: " ++ show (C.ppMemWrites mem_writes))+            (List.concat $ IntMap.elems mmm)+          _ -> fail $ "SimpleLoopFixpoint: not MemWritesChunkIndexed: " ++ show (C.ppMemWrites mem_writes)++        -- check that the mem substitution always computes the same footprint on every iteration (!?!)+        mem_substitution <- if Map.null (fixpointMemSubstitution fixpoint_record)+          then return mem_substitution_candidate+          else if Map.keys mem_substitution_candidate == Map.keys (fixpointMemSubstitution fixpoint_record)+            then return $ fixpointMemSubstitution fixpoint_record+            else fail "SimpleLoopFixpoint: unsupported memory writes change"++        assumption_frame_identifier <- C.pushAssumptionFrame bak++        -- check if we are done; if we did not introduce any new variables, we don't have to widen any more+        if MapF.keys join_substitution == MapF.keys (fixpointSubstitution fixpoint_record)++          -- we found the fixpoint, get ready to wrap up+          then do+            ?logMessage $+              "SimpleLoopFixpoint: RunningState: ComputeFixpoint -> CheckFixpoint"+            ?logMessage $+              "SimpleLoopFixpoint: cond: " +++                  show (maybe "Nothing" W4.printSymExpr $ fixpointLoopCondition fixpoint_record)++            -- we have delayed populating the main substituation map with+            --  memory variables, so we have to do that now++            header_mem_substitution <- loadMemJoinVariables bak header_mem_impl $+              fixpointMemSubstitution fixpoint_record+            body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $+              fixpointMemSubstitution fixpoint_record++            -- try to unify widening variables that have the same values+            let (normal_substitution, equality_substitution) = uninterpretedConstantEqualitySubstitution sym $+                  -- drop variables that don't appear along some back edge (? understand this better)+                  filterSubstitution sym $+                  MapF.union join_substitution $+                  -- this implements zip, because the two maps have the same keys+                  MapF.intersectWithKeyMaybe+                    (\_k x y -> Just $ FixpointEntry{ headerValue = x, bodyValue = y })+                    header_mem_substitution+                    body_mem_substitution+            -- ?logMessage $ "normal_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList normal_substitution)+            -- ?logMessage $ "equality_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList equality_substitution)++            -- unify widening variables in the register subst+            let res_reg_map = applySubstitutionRegEntries sym equality_substitution join_reg_map++            -- unify widening varialbes in the memory subst+            res_mem_impl <- storeMemJoinVariables+              bak+              (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) })+              mem_substitution+              equality_substitution++            -- finally we can determine the loop bounds+            loop_index_bound <- findLoopIndexBound sym normal_substitution $ fixpointLoopCondition fixpoint_record++            (_ :: ()) <- case loop_index_bound of+              LoopIndexBound{ index = loop_index, stop = loop_stop } -> do+                loc <- W4.getCurrentProgramLoc sym+                index_bound_condition <- loopIndexBoundCondition sym loop_index loop_stop+                C.addAssumption bak $ C.GenericAssumption loc "" index_bound_condition+                index_start_step_condition <- loopIndexStartStepCondition sym loop_index_bound+                C.addAssumption bak $ C.GenericAssumption loc "" index_start_step_condition++            writeIORef fixpoint_state_ref $+              CheckFixpoint+                FixpointRecord+                { fixpointBlockId = C.Some block_id+                , fixpointAssumptionFrameIdentifier = assumption_frame_identifier+                , fixpointSubstitution = normal_substitution+                , fixpointRegMap = C.RegMap res_reg_map+                , fixpointMemSubstitution = mem_substitution+                , fixpointLoopCondition = fixpointLoopCondition fixpoint_record+                }+                loop_index_bound++            return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+              sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap res_reg_map+                & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++          else do+            ?logMessage $+              "SimpleLoopFixpoint: RunningState: ComputeFixpoint: -> ComputeFixpoint"++            -- write any new widening variables into memory state+            res_mem_impl <- storeMemJoinVariables bak+              (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) })+              mem_substitution+              MapF.empty++            writeIORef fixpoint_state_ref $ ComputeFixpoint+              FixpointRecord+              { fixpointBlockId = C.Some block_id+              , fixpointAssumptionFrameIdentifier = assumption_frame_identifier+              , fixpointSubstitution = join_substitution+              , fixpointRegMap = C.RegMap join_reg_map+              , fixpointMemSubstitution = mem_substitution+              , fixpointLoopCondition = Nothing+              }+            return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+              sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap join_reg_map+                & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++      | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: ComputeFixpoint"]++    CheckFixpoint fixpoint_record loop_bound+      | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record+      , Just Refl <- W4.testEquality+          (fmapFC C.regType $ C.regMap reg_map)+          (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do+        ?logMessage $+          "SimpleLoopFixpoint: RunningState: "+          ++ "CheckFixpoint"+          ++ " -> "+          ++ "AfterFixpoint"+          ++ ": "+          ++ show block_id++        loc <- W4.getCurrentProgramLoc sym++        -- assert that the hypothesis we made about the loop termination condition is true+        (_ :: ()) <- case loop_bound of+          LoopIndexBound{ index = loop_index, stop = loop_stop } -> do+            -- check the loop index bound condition+            index_bound_condition <- loopIndexBoundCondition+              sym+              (bodyValue $ fromJust $ MapF.lookup loop_index $ fixpointSubstitution fixpoint_record)+              loop_stop+            C.addProofObligation bak $ C.LabeledPred index_bound_condition $ C.SimError loc ""++        _ <- C.popAssumptionFrame bak $ fixpointAssumptionFrameIdentifier fixpoint_record++        let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals)+        let (header_mem_impl, _mem_allocs, _mem_writes) = dropMemStackFrame body_mem_impl++        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+        (fixpoint_func_substitution, fixpoint_func_condition) <- liftIO $+          case fixpointLoopCondition fixpoint_record of+            Nothing -> fail "When checking the result of a fixpoint, no loop condition was found!"+            Just c  -> fixpoint_func res_substitution c++        C.addProofObligation bak $ C.LabeledPred fixpoint_func_condition $ C.SimError loc ""+        -- ?logMessage $ "fixpoint_func_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList fixpoint_func_substitution)++        let res_reg_map = C.RegMap $+              applySubstitutionRegEntries sym fixpoint_func_substitution (C.regMap reg_map)++        res_mem_impl <- storeMemJoinVariables bak+          header_mem_impl+          (fixpointMemSubstitution fixpoint_record)+          fixpoint_func_substitution++        (_ :: ()) <- case loop_bound of+          LoopIndexBound{ index = loop_index, stop = loop_stop } -> do+            let loop_index' = MapF.findWithDefault loop_index loop_index fixpoint_func_substitution+            index_bound_condition <- loopIndexBoundCondition sym loop_index' loop_stop+            C.addAssumption bak $ C.GenericAssumption loc "" index_bound_condition+            index_start_step_condition <- loopIndexStartStepCondition sym $ LoopIndexBound+              { index = loop_index'+              , start = start loop_bound+              , stop = loop_stop+              , step = step loop_bound+              }+            C.addAssumption bak $ C.GenericAssumption loc "" index_start_step_condition++        writeIORef fixpoint_state_ref $+          AfterFixpoint+            fixpoint_record{ fixpointSubstitution = res_substitution }+            loop_bound++        return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+          sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ res_reg_map+            & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++      | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: CheckFixpoint"]++    AfterFixpoint{} -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["AfterFixpoint"]+++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 C.PausedFrame{ resume = resume } = case resume of+  C.ContinueResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id+  C.CheckMergeResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id+  _ -> NothingPausedFrameTgtId
+ src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs view
@@ -0,0 +1,1211 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.SimpleLoopInvariant+-- Description      : Execution feature to perform verification of simply+--                    structured loops via invariants.+-- Copyright        : (c) Galois, Inc 2022+-- License          : BSD3+-- Stability        : provisional+--+--+-- This module provides an execution feature that can be installed+-- into the Crucible simulator which facilitates reasoning about+-- certain kinds of loops by using loop invariants instead of+-- requiring that loops symbolically terminate. In order for this+-- feature to work, the loop in question needs to be+-- single-entry/single-exit, and needs to have a constant memory+-- footprint on each loop iteration (except that memory regions backed+-- by SMT arrays are treated as a whole, so loops can write into+-- different regions of an SMT-array memory region on different+-- iterations). In addition, loop-involved memory writes must be+-- sufficiently concrete that we can determine their region values,+-- and writes to the same region value must have concrete distances+-- from each other, so we can determine if/when they alias.+--+-- To set up a loop invariant for a loop, you must specify which CFG the+-- loop is in, indicate which loop (of potentially several) in the CFG+-- is the one of interest, and give a function that is used to construct+-- the statement of the loop invariant. When given a CFG, the execution+-- feature computes a weak topological ordering to find the loops in+-- the program; the number given by the user selects which of these to+-- install the invariant for.+--+-- At runtime, we will interrupt execution when the loop head is+-- reached; at this point we will record the values of the memory and+-- the incoming local variables. Then, we will begin a series of+-- "hypothetical" executions of the loop body and track how the memory+-- and local variables are modified by the loop body. On each+-- iteration where we find a difference, we replace the local or+-- memory region with a fresh "join variable" which represents the+-- unknown value of a loop-carried dependency. We continue this process+-- until we reach a fixpoint; then we will have captured all the locations+-- that are potentially of interest for the loop invariant.+--+-- Once we have found all the loop-carried dependencies, we assert+-- that the loop invariant holds on the initial values upon entry to the+-- loop. Then, we set up another execution starting from the loop head+-- where we first assume the loop invariant over the join variables+-- invented earlier, and begin execution again.  In this mode, when we+-- reach the loop head once more, we assert the loop invariant on the+-- computed values and abort execution along that path. Paths exiting+-- the loop continue as normal.+--+-- Provided the user suppiles an appropriate loop invarant function+-- and can discharge all the generated proof obligations, this procedure+-- should result in a sound proof of partial correctness for the function+-- in question.+--+-- This whole procedure has some relatively fragile elements that are+-- worth calling out.  First, specifying which loop you want to reason+-- about may require some trial-and-error, the WTO ordering might not+-- directly correspond to what is seen in the source code. The most+-- reliable way to select the right loop is to ensure there is only+-- one loop of interest in a given function, and use loop index 0.+-- The other fragility has to do with the discovery of loop-carried+-- dependencies. The number and order of values that are supplied to+-- the loop invariant depend on the internal details of the compiler+-- and simulator, so the user may have to spend some time and effort+-- to discover what the values appearing in the invariant correspond+-- to. This process may well be quite sensitive to changes in the+-- source code.+--+-- Limitiations: currently, this feature is restricted to 64-bit code.+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++module Lang.Crucible.LLVM.SimpleLoopInvariant+  ( InvariantEntry(..)+  , InvariantPhase(..)+  , simpleLoopInvariant+  ) where++import           Control.Lens+import           Control.Monad (forM, unless, when)+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Except (ExceptT, MonadError(..), runExceptT)+import           Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)+import           Control.Monad.State (MonadState(..), StateT(..))+import           Data.Foldable+import qualified Data.IntMap as IntMap+import           Data.IORef+import qualified Data.List as List+import           Data.Maybe+import qualified Data.Map as Map+import           Data.Map (Map)+import qualified Data.Set as Set+import qualified System.IO+import           Numeric.Natural+import           Prettyprinter (pretty)++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.TraversableF+import           Data.Parameterized.TraversableFC++import qualified What4.Config as W4+import qualified What4.Interface as W4+import qualified What4.ProgramLoc 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.CFG.Extension 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+++-- | A datatype describing the reason we are building an instance+--   of the loop invariant.+data InvariantPhase+  = InitialInvariant+  | HypotheticalInvariant+  | InductiveInvariant+ deriving (Eq, Ord, Show)++-- | 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 varible, 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+--   any more fresh widening variables, and the body values for each+--   variable are stable across iterations.+data InvariantEntry sym tp =+  InvariantEntry+  { headerValue :: W4.SymExpr sym tp+  , bodyValue :: W4.SymExpr sym tp+  }++instance OrdF (W4.SymExpr sym) => OrdF (InvariantEntry sym) where+  compareF x y = case compareF (headerValue x) (headerValue y) of+    LTF -> LTF+    EQF -> compareF (bodyValue x) (bodyValue y)+    GTF -> GTF++instance OrdF (InvariantEntry sym) => W4.TestEquality (InvariantEntry sym) where+  testEquality x y = orderingF_refl (compareF x y)++-- | This datatype captures the state machine that progresses as we+--   attempt to compute a loop invariant for a simple structured loop.+data FixpointState p sym ext rtp blocks+    -- | 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 C.FrameIdentifier (FixpointRecord p sym ext rtp blocks)++    -- | We have found an inductively-strong representation of the live variables+    --   of the loop. We are now executing the from the loop head one final time+    --   to produce the proof obligations arising from the body of the loop,+    --   the main inductive loop invariant obligation, and any obligations arising+    --   from code following the loop exit.+    | CheckFixpoint (FixpointRecord p sym ext rtp blocks)+++-- | Data about the loop that we incrementally compute as we approach fixpoint.+data FixpointRecord p sym ext rtp blocks = forall args r.+  FixpointRecord+  {+    -- | Block identifier of the head of the loop+    fixpointBlockId :: C.BlockID blocks args++    -- | 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.+  , fixpointSubstitution :: VariableSubst sym++    -- | The memory subsitution describes where the loop-carried dependencies live in the+    --   memory.+  , fixpointMemSubstitution :: MemorySubstitution sym++    -- | Prestate values of the Crucible registers when the loop header is first encountered.+  , fixpointRegMap :: C.RegMap sym args++    -- | The sim state of the simulator when we first encounter the loop header.+  , fixpointInitialSimState :: C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args)++    -- | External constants appearing in the expressions computed by the loop. These will be passed+    --   into the loop invariant as additional parameters.+  , fixpointImplicitParams :: [Some (W4.SymExpr sym)]++    -- | A special memory region number that does not correspond to any valid block.+    --   This is intended to model values the block portion of bitvector values that+    --   get clobbered by the loop body, but do not represent loop-carried dependencies.+  , fixpointHavocBlock :: W4.SymNat sym+  }++-- | A variable substitution is used to track metadata regarding the discovered+--   loop-carried dependencies of a loop.+data VariableSubst sym =+  VarSubst+  { varSubst :: MapF (W4.SymExpr sym) (InvariantEntry sym)+    -- ^ The @varSubst@ associates to each "join variable" an @InvariantEntry@,+    --   that descibes the initial value the variable had, and the value computed+    --   for it after a loop iteration.++  , varHavoc :: MapF (W4.SymExpr sym) (Const ())+    -- ^ The @varHavoc@ map is essentially just a set of "join variables" for which+    --   we were not able to compute a coherent value across the loop boundary.+    --   Such variables are considered to be "junk" at the beginning of the loop,+    --   and do not participate in the loop invariant. This usually arises from+    --   temporary scratch space used in the loop body.+  }+++-- | A memory region is used to describe a contiguous sequence of bytes+--   which is of known size, and which is at a known, concrete, offset+--   from a "master" offset. In a given regualar memory block, these+--   regions are required to be disjoint.+data MemoryRegion sym =+  forall w. (1 <= w) =>+  MemoryRegion+  { regionOffset  :: BV.BV 64 -- ^ Offset of the region, from the base pointer+  , regionSize    :: C.Bytes  -- ^ Length of the memory region, in bytes+  , regionStorage :: C.StorageType -- ^ The storage type used to write to this region+  , regionJoinVar :: W4.SymBV sym w -- ^ The join variable representing this region+  }++-- | Memory block data are used to describe where in memory+--   loop-carried dependencies are.  They may either be+--   "regular" blocks or "array" blocks. A regular block+--   consists of a collection of regions of known size, each+--   of which is at some concretely-known offset from a single+--   master offset value inside the LLVM memory region.+--   An array block consists of an entire LLVM memory region+--   that is backed by an SMT array.+data MemoryBlockData sym where+  RegularBlock ::+    W4.SymBV sym 64+      {- ^ A potentially symbolic base pointer/offset. All the+           offsets in this region are required to be at a concrete+           distance from this base pointer. -} ->+    Map Natural (MemoryRegion sym)+      {- ^ mapping from offset values to regions -} ->+    MemoryBlockData sym++  ArrayBlock   ::+    W4.SymExpr sym ArrayTp {- ^ array join variable -} ->+    W4.SymBV sym 64 {- ^ length of the allocation -} ->+    MemoryBlockData sym++type ArrayTp = W4.BaseArrayType (C.EmptyCtx C.::> W4.BaseBVType 64) (W4.BaseBVType 8)++-- | A memory substitution gives memory block data for+--   concrete memory region numbers of writes occurring+--   in the loop body. This is used to determine where+--   in memory the relevant values are that need to be+--   passed to the loop invariant.+newtype MemorySubstitution sym =+  MemSubst+  { memSubst :: Map Natural (MemoryBlockData sym)+      {- ^ Mapping from block numbers to block data -}+  }+++fixpointRecord ::+  FixpointState p sym ext rtp blocks ->+  Maybe (FixpointRecord p sym ext rtp blocks)+fixpointRecord BeforeFixpoint = Nothing+fixpointRecord (ComputeFixpoint _ r) = Just r+fixpointRecord (CheckFixpoint r) = Just r+++-- The fixpoint monad is used to ease the process of computing variable widenings+-- and such.  The included "SymNat" is a memory region number guaranteed not+-- to be a valid memory region; it is used to implement "havoc" registers that+-- we expect to be junk/scratch space across the loop boundary.+-- The state component tracks the variable substitution we are computing.+newtype FixpointMonad sym a =+  FixpointMonad (ReaderT (W4.SymNat sym) (StateT (VariableSubst sym) IO) a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadFail)++deriving instance MonadReader (W4.SymNat sym) (FixpointMonad sym)+deriving instance MonadState (VariableSubst sym) (FixpointMonad sym)++runFixpointMonad ::+  W4.SymNat sym ->+  VariableSubst sym ->+  FixpointMonad sym a ->+  IO (a, VariableSubst sym)+runFixpointMonad havoc_blk subst (FixpointMonad m) =+  runStateT (runReaderT m havoc_blk) subst++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 sym = Ctx.zipWithM (joinRegEntry sym)++joinRegEntry ::+  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>+  sym ->+  C.RegEntry sym tp ->+  C.RegEntry sym tp ->+  FixpointMonad sym (C.RegEntry sym tp)+joinRegEntry sym left right = do+ subst <- get+ case C.regType left of+  C.LLVMPointerRepr w++      -- TODO! This is a "particularly guesome hack" it would be nice to find some better+      --  way to handle this situation.+      -- special handling for "don't care" registers coming from Macaw+    | List.isPrefixOf "cmacaw_reg" (show $ W4.printSymNat $ C.llvmPointerBlock (C.regValue left))+    , List.isPrefixOf "cmacaw_reg" (show $ W4.printSymExpr $ C.llvmPointerOffset (C.regValue left)) -> do+      -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: cmacaw_reg"+      return left++    | C.llvmPointerBlock (C.regValue left) == C.llvmPointerBlock (C.regValue right)+    , Nothing <- MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varHavoc subst) -> do+      -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr"+      if isJust (W4.testEquality (C.llvmPointerOffset (C.regValue left)) (C.llvmPointerOffset (C.regValue right)))+      then do+        -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: left == right"+        return left+      else case MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varSubst subst) of+        Just join_entry -> do+          -- liftIO $ ?logMessage $+          --   "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: Just: "+          --   ++ show (W4.printSymExpr $ bodyValue join_entry)+          --   ++ " -> "+          --   ++ show (W4.printSymExpr $ C.llvmPointerOffset (C.regValue right))+          put $ subst{ varSubst =+            MapF.insert+              (C.llvmPointerOffset (C.regValue left))+              (join_entry { bodyValue = C.llvmPointerOffset (C.regValue right) })+              (varSubst subst) }+          return left+        Nothing -> do+          liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: Nothing"+          join_variable <- liftIO $ W4.freshConstant sym+                             (W4.safeSymbol "reg_join_var") (W4.BaseBVRepr w)+          let join_entry = InvariantEntry+                { headerValue = C.llvmPointerOffset (C.regValue left)+                , bodyValue = C.llvmPointerOffset (C.regValue right)+                }+          put $ subst{ varSubst = MapF.insert join_variable join_entry (varSubst subst) }+          return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) join_variable++    | otherwise -> do+      liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr, unequal blocks!"+      havoc_blk <- ask+      case MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varSubst subst) of+        Just _ -> do+          -- widening varible already present in the var substitition.+          -- we need to remove it, and add it to the havoc map instead+          put subst { varSubst = MapF.delete (C.llvmPointerOffset (C.regValue left)) (varSubst subst)+                    , varHavoc = MapF.insert (C.llvmPointerOffset (C.regValue left)) (Const ()) (varHavoc subst)+                    }+          return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer havoc_blk (C.llvmPointerOffset (C.regValue left))++        Nothing -> do+          havoc_var <- liftIO $ W4.freshConstant sym (W4.safeSymbol "havoc_var") (W4.BaseBVRepr w)+          put subst{ varHavoc = MapF.insert havoc_var (Const ()) (varHavoc subst) }+          return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer havoc_blk havoc_var++  C.BoolRepr+    | List.isPrefixOf "cmacaw" (show $ W4.printSymExpr $ C.regValue left) -> do+      liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: cmacaw_reg"+      return left+    | otherwise -> do+      -- liftIO $ ?logMessage $+      --   "SimpleLoopInvariant.joinRegEntry: BoolRepr:"+      --   ++ show (W4.printSymExpr $ C.regValue left)+      --   ++ " \\/ "+      --   ++ show (W4.printSymExpr $ C.regValue right)+      join_varaible <- liftIO $ W4.freshConstant sym (W4.safeSymbol "reg_join_var") W4.BaseBoolRepr+      return $ C.RegEntry C.BoolRepr join_varaible++  C.StructRepr field_types -> do+    -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: StructRepr"+    C.RegEntry (C.regType left) <$> fmapFC (C.RV . C.regValue) <$> joinRegEntries sym+      (Ctx.generate (Ctx.size field_types) $ \i ->+        C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue left) Ctx.! i)+      (Ctx.generate (Ctx.size field_types) $ \i ->+        C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue right) Ctx.! i)+  _ -> fail $ "SimpleLoopInvariant.joinRegEntry: unsupported type: " ++ show (C.regType 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 sym substitution = fmapFC (applySubstitutionRegEntry sym substitution)++applySubstitutionRegEntry ::+  C.IsSymInterface sym =>+  sym ->+  (MapF (W4.SymExpr sym) (W4.SymExpr sym)) ->+  C.RegEntry sym tp ->+  C.RegEntry sym tp+applySubstitutionRegEntry sym substitution entry = case C.regType entry of+  C.LLVMPointerRepr{} ->+    entry+      { C.regValue = C.LLVMPointer+          (C.llvmPointerBlock (C.regValue entry))+          (MapF.findWithDefault+            (C.llvmPointerOffset (C.regValue entry))+            (C.llvmPointerOffset (C.regValue entry))+            substitution)+      }+  C.BoolRepr ->+    entry+  C.StructRepr field_types ->+    entry+      { C.regValue = fmapFC (C.RV . C.regValue) $+          applySubstitutionRegEntries sym substitution $+          Ctx.generate (Ctx.size field_types) $+          \i -> C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue entry) Ctx.! i+      }+  _ -> error $ unlines [ "SimpleLoopInvariant.applySubstitutionRegEntry"+                       , "unsupported type: " ++ show (C.regType entry)+                       ]+++loadMemJoinVariables ::+  (C.IsSymBackend sym bak, C.HasPtrWidth 64, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>+  bak ->+  C.MemImpl sym ->+  MemorySubstitution sym ->+  IO (MapF (W4.SymExpr sym) (W4.SymExpr sym))+loadMemJoinVariables bak mem (MemSubst subst) = do+  let sym = C.backendGetSym bak++  vars <- forM (Map.toAscList subst) $ \ (blk, blkData) ->+            case blkData of+              ArrayBlock arr_var _sz ->+                do base_ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 0)+                   res <- C.asMemAllocationArrayStore sym ?ptrWidth base_ptr (C.memImplHeap mem)+                   case res of+                     Nothing -> fail $ "Expected SMT array in memory image for block number: " ++ show blk+                     Just (_ok, arr, _len2) ->+                       -- TODO: we need to assert the load condition...+                       -- TODO? Should we assert the lengths match?++                       return [MapF.Pair arr_var arr]++              RegularBlock basePtr offsetMap ->+                forM (Map.toAscList offsetMap) $+                  \ (_off , MemoryRegion{ regionJoinVar = join_var, regionStorage = storage_type, regionOffset = offBV }) ->+                    do blk' <- W4.natLit sym blk+                       off' <- W4.bvAdd sym basePtr =<< W4.bvLit sym ?ptrWidth offBV+                       let ptr = C.LLVMPointer blk' off'+                       val <- safeBVLoad sym mem ptr storage_type join_var C.noAlignment+                       return (MapF.Pair join_var val)++  return (MapF.fromList (concat vars))+++safeBVLoad ::+  ( C.IsSymInterface sym, C.HasPtrWidth wptr, C.HasLLVMAnn sym+  , ?memOpts :: C.MemOptions, 1 <= w ) =>+  sym ->+  C.MemImpl sym ->+  C.LLVMPtr sym wptr {- ^ pointer to load from      -} ->+  C.StorageType      {- ^ type of value to load     -} ->+  W4.SymBV sym w     {- ^ default value to return -} ->+  C.Alignment        {- ^ assumed pointer alignment -} ->+  IO (C.RegValue sym (C.BVType w))+safeBVLoad sym mem ptr st def align =+  do let w = W4.bvWidth def+     pval <- C.loadRaw sym mem ptr st align+     case pval of+       C.Err _ -> return def+       C.NoErr p v ->+         do v' <- C.unpackMemValue sym (C.LLVMPointerRepr w) v+            p0 <- W4.natEq sym (C.llvmPointerBlock v') =<< W4.natLit sym 0+            p' <- W4.andPred sym p p0+            W4.bvIte sym p' (C.llvmPointerOffset v') def++storeMemJoinVariables ::+  (C.IsSymBackend sym bak, C.HasPtrWidth 64, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>+  bak ->+  C.MemImpl sym ->+  MemorySubstitution sym ->+  MapF (W4.SymExpr sym) (W4.SymExpr sym) ->+  IO (C.MemImpl sym)+storeMemJoinVariables bak mem (MemSubst mem_subst) eq_subst =+  foldlM+     (\mem_acc (blk, blk_data) ->+        case blk_data of+          RegularBlock basePtr off_map ->+            foldlM (writeMemRegion blk basePtr) mem_acc (Map.toAscList off_map)+          ArrayBlock arr len ->+            do base_ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 0)+               let arr' = MapF.findWithDefault arr arr eq_subst+               C.doArrayStore bak mem_acc base_ptr C.noAlignment arr' len)+     mem+     (Map.toAscList mem_subst)++ where+  sym = C.backendGetSym bak++  writeMemRegion blk basePtr mem_acc (_off, MemoryRegion{ regionJoinVar = join_var, regionStorage = storage_type, regionOffset = offBV }) =+    do blk' <- W4.natLit sym blk+       off' <- W4.bvAdd sym basePtr =<< W4.bvLit sym ?ptrWidth offBV+       let ptr = C.LLVMPointer blk' off'+       C.doStore bak mem_acc ptr (C.LLVMPointerRepr $ W4.bvWidth join_var) storage_type C.noAlignment =<<+         C.llvmPointer_bv sym (MapF.findWithDefault join_var join_var eq_subst)++++dropMemStackFrame :: C.IsSymInterface sym => C.MemImpl sym -> (C.MemImpl sym, C.MemAllocs sym, C.MemWrites sym)+dropMemStackFrame mem = case (C.memImplHeap mem) ^. C.memState of+  (C.StackFrame _ _ _ (a, w) s) -> ((mem { C.memImplHeap = (C.memImplHeap mem) & C.memState .~ s }), a, w)+  _ -> C.panic "SimpleLoopInvariant.dropMemStackFrame" ["not a stack frame:", show (C.ppMem $ C.memImplHeap mem)]+++filterSubstitution ::+  C.IsSymInterface sym =>+  sym ->+  VariableSubst sym ->+  VariableSubst sym+filterSubstitution sym (VarSubst substitution havoc) =+  -- TODO: fixpoint+  let uninterp_constants = foldMapF+        (Set.map (C.mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . bodyValue)+        substitution+  in+  VarSubst+    (MapF.filterWithKey (\variable _entry -> Set.member (C.Some variable) uninterp_constants) substitution)+    havoc++-- find widening variables that are actually the same (up to syntactic equality)+-- and can be substituted for each other+uninterpretedConstantEqualitySubstitution ::+  forall sym .+  C.IsSymInterface sym =>+  sym ->+  VariableSubst sym ->+  (VariableSubst sym, MapF (W4.SymExpr sym) (W4.SymExpr sym))+uninterpretedConstantEqualitySubstitution _sym (VarSubst substitution havoc) =+  let reverse_substitution = MapF.foldlWithKey'+        (\accumulator variable entry -> MapF.insert entry variable accumulator)+        MapF.empty+        substitution+      uninterpreted_constant_substitution = fmapF+        (\entry -> fromJust $ MapF.lookup entry reverse_substitution)+        substitution+      normal_substitution = MapF.filterWithKey+        (\variable _entry ->+          Just Refl == W4.testEquality variable (fromJust $ MapF.lookup variable uninterpreted_constant_substitution))+        substitution+  in+  (VarSubst normal_substitution havoc, uninterpreted_constant_substitution)+++-- | 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 limititations.+--   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.+simpleLoopInvariant ::+  forall sym ext p rtp blocks init ret .+  (C.IsSymInterface sym, C.IsSyntaxExtension ext, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) =>+  sym ->+  Integer {- ^ which of the discovered loop heads to install a loop invariant onto -}  ->+  C.CFG ext blocks init ret {- ^ The function we want to verify -} ->+  C.GlobalVar C.Mem {- ^ global variable representing memory -} ->+  (InvariantPhase -> [Some (W4.SymExpr sym)] -> MapF (W4.SymExpr sym) (InvariantEntry sym) -> IO (W4.Pred sym)) ->+  IO (C.ExecutionFeature p sym ext rtp)+simpleLoopInvariant sym loopNum cfg@C.CFG{..} mem_var loop_invariant = do+  -- TODO, can we lift this restriction to 64-bits? I don't think there+  -- is anything fundamental about it.+  let ?ptrWidth = knownNat @64++  verbSetting <- W4.getOptionSetting W4.verbosity $ W4.getConfiguration sym+  verb <- fromInteger <$> W4.getOpt verbSetting++  (loop_header, loop_body_blocks) <- computeLoopBlocks cfg loopNum++  fixpoint_state_ref <- newIORef @(FixpointState p sym ext rtp blocks) BeforeFixpoint++  --putStrLn "Setting up simple loop fixpoints feature."+  --putStrLn ("WTO: " ++ show (C.cfgWeakTopologicalOrdering cfg))++  return $ C.ExecutionFeature $ \exec_state -> do+    let ?logMessage = \msg -> when (verb >= (3 :: Natural)) $ do+          let h = C.printHandle $ C.execStateContext exec_state+          System.IO.hPutStrLn h msg+          System.IO.hFlush h++    fixpoint_state <- readIORef fixpoint_state_ref+    C.withBackend (C.execStateContext exec_state) $ \bak ->+     case exec_state of+      C.RunningState (C.RunBlockStart block_id) sim_state+        | C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)++        -- make sure the types match+        , Just Refl <- W4.testEquality+            (fmapFC C.blockInputs cfgBlockMap)+            (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)++          -- is this state at thea loop header?+        , C.Some block_id == loop_header ->++            advanceFixpointState bak mem_var loop_invariant block_id sim_state fixpoint_state fixpoint_state_ref++        | otherwise -> do+            ?logMessage $ "SimpleLoopInvariant: RunningState: RunBlockStart: " ++ show block_id ++ " " ++ show (C.frameHandle (sim_state ^. C.stateCrucibleFrame))+            return C.ExecutionFeatureNoChange++      C.SymbolicBranchState branch_condition true_frame false_frame _target sim_state+          | Just _fixpointRecord <- fixpointRecord fixpoint_state+          , JustPausedFrameTgtId true_frame_some_block_id <- pausedFrameTgtId true_frame+          , JustPausedFrameTgtId false_frame_some_block_id <- pausedFrameTgtId false_frame+          , C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame)+          , Just Refl <- W4.testEquality+              (fmapFC C.blockInputs cfgBlockMap)+              (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame)+          , elem true_frame_some_block_id loop_body_blocks /=+              elem false_frame_some_block_id loop_body_blocks -> do++            (loop_condition, inside_loop_frame) <-+              if elem true_frame_some_block_id loop_body_blocks+              then+                return (branch_condition, true_frame)+              else do+                not_branch_condition <- W4.notPred sym branch_condition+                return (not_branch_condition, false_frame)++            case fixpoint_state of+              BeforeFixpoint -> C.panic "SimpleLoopInvariant.simpleLoopInvariant:" ["BeforeFixpoint"]++              ComputeFixpoint _assumeIdent _fixpoint_record -> do+                -- continue in the loop+                ?logMessage $ "SimpleLoopInvariant: SymbolicBranchState: ComputeFixpoint"++                loc <- W4.getCurrentProgramLoc sym+                C.addAssumption bak $ C.BranchCondition loc (C.pausedLoc inside_loop_frame) loop_condition++                C.ExecutionFeatureNewState <$>+                  runReaderT+                    (C.resumeFrame (C.forgetPostdomFrame inside_loop_frame) $ sim_state ^. (C.stateTree . C.actContext))+                    sim_state++              CheckFixpoint _fixpoint_record -> do+                ?logMessage $ "SimpleLoopInvariant: SymbolicBranchState: CheckFixpoint"++                return C.ExecutionFeatureNoChange++      _ -> return C.ExecutionFeatureNoChange+++advanceFixpointState ::+  forall sym bak ext p rtp blocks r args .+  (C.IsSymBackend sym bak, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) =>+  bak ->+  C.GlobalVar C.Mem ->+  (InvariantPhase -> [Some (W4.SymExpr sym)] -> MapF (W4.SymExpr sym) (InvariantEntry sym) -> IO (W4.Pred sym)) ->+  C.BlockID blocks args ->+  C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) ->+  FixpointState p sym ext rtp blocks ->+  IORef (FixpointState p sym ext rtp blocks) ->+  IO (C.ExecutionFeatureResult p sym ext rtp)++advanceFixpointState bak mem_var loop_invariant block_id sim_state fixpoint_state fixpoint_state_ref = do+  let ?ptrWidth = knownNat @64+  let sym = C.backendGetSym bak+  loc <- W4.getCurrentProgramLoc sym+  case fixpoint_state of+    BeforeFixpoint -> do+      ?logMessage $ "SimpleLoopInvariant: RunningState: BeforeFixpoint -> ComputeFixpoint " ++ show block_id ++ " " ++ show (pretty (W4.plSourceLoc loc))+      assumption_frame_identifier <- C.pushAssumptionFrame bak+      let mem_impl = case C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) of+                       Just m -> m+                       Nothing -> C.panic "SimpleLoopInvariant.advanceFixpointState"+                                          ["LLVM Memory variable not found!"]+      let res_mem_impl = mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" $ C.memImplHeap mem_impl }++--      ?logMessage $ "SimpleLoopInvariant: start memory\n" ++ (show (C.ppMem (C.memImplHeap mem_impl)))++      -- Get a fresh block value that doesn't correspond to any valid memory region+      havoc_blk <- W4.natLit sym =<< C.nextBlock (C.memImplBlockSource mem_impl)++      writeIORef fixpoint_state_ref $ ComputeFixpoint assumption_frame_identifier $+        FixpointRecord+        { fixpointBlockId = block_id+        , fixpointSubstitution = VarSubst MapF.empty MapF.empty+        , fixpointRegMap = sim_state ^. (C.stateCrucibleFrame . C.frameRegs)+        , fixpointMemSubstitution = MemSubst mempty+        , fixpointInitialSimState = sim_state+        , fixpointImplicitParams = []+        , fixpointHavocBlock = havoc_blk+        }+      return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+        sim_state & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++    ComputeFixpoint assumeFrame fixpoint_record+      | FixpointRecord { fixpointRegMap = reg_map+                       , fixpointInitialSimState = initSimState+                       , fixpointHavocBlock = havoc_blk+                       }+           <- fixpoint_record+      , Just Refl <- W4.testEquality+          (fmapFC C.regType $ C.regMap reg_map)+          (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do+++        ?logMessage $ "SimpleLoopInvariant: RunningState: ComputeFixpoint: " ++ show block_id+        _ <- C.popAssumptionFrameAndObligations bak assumeFrame++        let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals)+        let (header_mem_impl, mem_allocs, mem_writes) = dropMemStackFrame body_mem_impl+        when (C.sizeMemAllocs mem_allocs /= 0) $+          fail "SimpleLoopInvariant: unsupported memory allocation in loop body."++        -- widen the inductive condition+        ((join_reg_map,mem_substitution), join_substitution) <-+            runFixpointMonad havoc_blk (fixpointSubstitution fixpoint_record) $+               do join_reg_map <- joinRegEntries sym+                                    (C.regMap reg_map)+                                    (C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs))+                  mem_substitution <- computeMemSubstitution sym fixpoint_record mem_writes+                  return (join_reg_map, mem_substitution)++        -- check if we are done; if we did not introduce any new variables, we don't have to widen any more+        if MapF.keys (varSubst join_substitution) ==+           MapF.keys (varSubst (fixpointSubstitution fixpoint_record))++          -- we found the fixpoint, get ready to wrap up+          then do+            ?logMessage $+              "SimpleLoopInvariant: RunningState: ComputeFixpoint -> CheckFixpoint "+              ++ " " ++ show (pretty (W4.plSourceLoc loc))+            -- we have delayed populating the main substitution map with+            --  memory variables, so we have to do that now++            header_mem_substitution <- loadMemJoinVariables bak header_mem_impl $+              fixpointMemSubstitution fixpoint_record+            body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $+              fixpointMemSubstitution fixpoint_record++            -- try to unify widening variables that have the same values+            let (normal_substitution, equality_substitution) =+                  uninterpretedConstantEqualitySubstitution sym $+                  -- drop variables that don't appear along some back edge (? understand this better)+                  filterSubstitution sym $+                  join_substitution+                  { varSubst =+                    MapF.union (varSubst join_substitution) $+                    -- this implements zip, because the two maps have the same keys+                    MapF.intersectWithKeyMaybe+                      (\_k x y -> Just $ InvariantEntry{ headerValue = x, bodyValue = y })+                      header_mem_substitution+                      body_mem_substitution+                  }+--            ?logMessage $ "normal_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList (varSubst normal_substitution))+--            ?logMessage $ "equality_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList equality_substitution)+--            ?logMessage $ "havoc variables: " ++ show (map (\(MapF.Pair x _) -> W4.printSymExpr x) $ MapF.toList (varHavoc normal_substitution))++            -- unify widening variables in the register subst+            let res_reg_map = applySubstitutionRegEntries sym equality_substitution join_reg_map++            -- unify widening variables in the memory subst+            res_mem_impl <- storeMemJoinVariables+              bak+              header_mem_impl+              mem_substitution+              equality_substitution++            -- == compute the list of "implicit parameters" that are relevant ==+            let implicit_params = Set.toList $+                  Set.difference+                    (foldMap+                       (\ (MapF.Pair _ e) ->+                            -- filter out the special "noSatisfyingWrite" boolean constants+                            -- that are generated as part of the LLVM memory model+                            Set.filter ( \ (C.Some x) ->+                                           not (List.isPrefixOf "cnoSatisfyingWrite"+                                                (show $ W4.printSymExpr x))) $+                            Set.map (\ (C.Some x) -> C.Some (W4.varExpr sym x)) $+                              (W4.exprUninterpConstants sym (bodyValue e)))+                       (MapF.toList (varSubst normal_substitution)))+                    (Set.fromList (MapF.keys (varSubst normal_substitution)))++            ?logMessage $ unlines $+              ["Implicit parameters!"] +++              map (\ (C.Some x) -> show (W4.printSymExpr x)) implicit_params++            -- == assert the loop invariant on the initial values ==++            -- build a map where the current value is equal to the initial value+            let init_state_map = MapF.map (\e -> e{ bodyValue = headerValue e })+                                          (varSubst normal_substitution)+            -- construct the loop invariant+            initial_loop_invariant <- loop_invariant InitialInvariant implicit_params init_state_map+            -- assert the loop invariant as an obligation+            C.addProofObligation bak+               $ C.LabeledPred initial_loop_invariant+               $ C.SimError loc "initial loop invariant"++            -- == assume the loop invariant on the arbitrary state ==++            -- build a map where the current value is equal to the widening variable+            let hyp_state_map = MapF.mapWithKey (\k e -> e{ bodyValue = k })+                                                (varSubst normal_substitution)+            -- construct the loop invariant to assume at the loop head+            hypothetical_loop_invariant <- loop_invariant HypotheticalInvariant implicit_params hyp_state_map+            -- assume the loop invariant+            C.addAssumption bak+              $ C.GenericAssumption loc "loop head invariant"+                hypothetical_loop_invariant++            -- == set up the state with arbitrary values to run the loop body ==++            writeIORef fixpoint_state_ref $+              CheckFixpoint+                FixpointRecord+                { fixpointBlockId = block_id+                , fixpointSubstitution = normal_substitution+                , fixpointRegMap = C.RegMap res_reg_map+                , fixpointMemSubstitution = mem_substitution+                , fixpointInitialSimState = initSimState+                , fixpointImplicitParams = implicit_params+                , fixpointHavocBlock = havoc_blk+                }++            -- Continue running from the loop header starting from an arbitrary state satisfying+            -- the loop invariant.+            return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+              initSimState & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap res_reg_map+                & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++          else do+            -- Otherwise, we are still working on finding all the loop-carried dependencies+            ?logMessage $+              "SimpleLoopInvariant: RunningState: ComputeFixpoint: -> ComputeFixpoint"+            assumption_frame_identifier <- C.pushAssumptionFrame bak++            -- write any new widening variables into memory state+            res_mem_impl <- storeMemJoinVariables bak+              (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) })+              mem_substitution+              MapF.empty++            writeIORef fixpoint_state_ref $+              ComputeFixpoint assumption_frame_identifier $+              FixpointRecord+              { fixpointBlockId = block_id+              , fixpointSubstitution = join_substitution+              , fixpointRegMap = C.RegMap join_reg_map+              , fixpointMemSubstitution = mem_substitution+              , fixpointInitialSimState = initSimState+              , fixpointImplicitParams = []+              , fixpointHavocBlock = havoc_blk+              }+            return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $+              initSimState & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap join_reg_map+                & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl++      | otherwise -> C.panic "SimpleLoopInvariant.simpleLoopInvariant" ["type mismatch: ComputeFixpoint"]++    CheckFixpoint fixpoint_record+      | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record+      , Just Refl <- W4.testEquality+          (fmapFC C.regType $ C.regMap reg_map)+          (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do+        ?logMessage $+          "SimpleLoopInvariant: RunningState: "+          ++ "CheckFixpoint"+          ++ " -> "+          ++ "AfterFixpoint"+          ++ ": "+          ++ show block_id+          ++ " " ++ show (pretty (W4.plSourceLoc loc))++        -- == assert the loop invariant and abort ==++        let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals)++        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+                  })+              (varSubst (fixpointSubstitution fixpoint_record))+        -- ?logMessage $ "res_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList res_substitution)++        invariant_pred <- loop_invariant InductiveInvariant (fixpointImplicitParams fixpoint_record) res_substitution+        C.addProofObligation bak $ C.LabeledPred invariant_pred $ C.SimError loc "loop invariant"+        -- ?logMessage $ "fixpoint_func_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList fixpoint_func_substitution)+        return $ C.ExecutionFeatureModifiedState $ C.AbortState (C.InfeasibleBranch loc) sim_state++      | otherwise -> C.panic "SimpleLoopInvariant.simpleLoopInvariant" ["type mismatch: CheckFixpoint"]++++constructMemSubstitutionCandidate :: forall sym.+  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>+  C.IsSymInterface sym =>+  sym ->+  C.MemWrites sym ->+  IO (MemorySubstitution sym)+constructMemSubstitutionCandidate sym mem_writes =+  case mem_writes of+    C.MemWrites [C.MemWritesChunkIndexed mmm] ->+      MemSubst <$> foldlM handleMemWrite mempty (List.concat $ IntMap.elems mmm)++    -- no writes occured in the body of the loop+    C.MemWrites [] ->+      return (MemSubst mempty)++    _ -> fail $ "SimpleLoopInvariant: not MemWritesChunkIndexed: " +++                show (C.ppMemWrites mem_writes)++ where+   updateOffsetMap ::+     Natural ->+     W4.SymBV sym 64 ->+     C.LLVMPtr sym 64 ->+     C.StorageType ->+     Map Natural (MemoryRegion sym) ->+     IO (Map Natural (MemoryRegion sym))+   updateOffsetMap blk basePtr ptr storage_type off_map =+     do diff <- W4.bvSub sym (C.llvmPointerOffset ptr) basePtr+        case W4.asBV diff of+          Nothing ->+            fail $ unlines+              [ "SimpleLoopInvariant: incompatible base pointers for writes to a memory region " ++ show blk+              , show (W4.printSymExpr basePtr)+              , show (W4.printSymExpr (C.llvmPointerOffset ptr))+              ]+          Just off ->+            do let sz = C.typeEnd 0 storage_type+               case Map.lookup (BV.asNatural off) off_map of+                 Just rgn+                   | regionSize rgn == sz -> return off_map+                   | otherwise ->+                       fail $ unlines+                         [ "Memory region written at incompatible storage types"+                         , show (regionStorage rgn) ++ " vs" ++ show storage_type+                         , show (C.ppPtr ptr)+                         ]+                 Nothing ->+                   case W4.mkNatRepr $ C.bytesToBits sz of+                     C.Some bv_width+                       | Just C.LeqProof <- W4.testLeq (W4.knownNat @1) bv_width -> do+                         join_var <- W4.freshConstant sym+                           (W4.safeSymbol ("mem_join_var_" ++ show blk ++ "_" ++ show (BV.asNatural off)))+                           (W4.BaseBVRepr bv_width)+                         let rgn = MemoryRegion+                                   { regionOffset  = off+                                   , regionSize    = sz+                                   , regionStorage = storage_type+                                   , regionJoinVar = join_var+                                   }+                         return (Map.insert (BV.asNatural off) rgn off_map)++                       | otherwise ->+                         C.panic+                           "SimpleLoopInvariant.simpleLoopInvariant"+                           ["unexpected storage type " ++ show storage_type ++ " of size " ++ show sz]+++   handleMemWrite mem_subst wr =+     case wr of+       C.MemWrite ptr (C.MemArrayStore _arr (Just len))+         | Just blk <- W4.asNat (C.llvmPointerBlock ptr)+         , Just Refl <- testEquality (knownNat @64) (W4.bvWidth len)+         -> case Map.lookup blk mem_subst of+              Just (ArrayBlock _ _) -> return mem_subst+              Just (RegularBlock _ _) ->+                fail $+                  "SimpleLoopInvariant: incompatible writes detected for block " ++ show blk+              Nothing ->+                do join_var <- liftIO $+                       W4.freshConstant sym+                         (W4.safeSymbol ("smt_array_join_var_" ++ show blk))+                         knownRepr+                   return (Map.insert blk (ArrayBlock join_var len) mem_subst)++       C.MemWrite ptr (C.MemStore _val storage_type _align)+        | Just blk <- W4.asNat (C.llvmPointerBlock ptr)+        , Just Refl <- testEquality (knownNat @64) (W4.bvWidth (C.llvmPointerOffset ptr))+        -> do (basePtr, off_map) <-+                case Map.lookup blk mem_subst of+                  Just (ArrayBlock _ _) ->+                     fail $+                       "SimpleLoopInvariant: incompatible writes detected for block " +++                       show blk+                  Just (RegularBlock basePtr off_map) -> return (basePtr, off_map)+                  Nothing -> return (C.llvmPointerOffset ptr, mempty)++              off_map' <- updateOffsetMap blk basePtr ptr storage_type off_map+              return (Map.insert blk (RegularBlock basePtr off_map') mem_subst)++       w -> fail $ unlines $+              [ "SimpleLoopInvariant: unable to handle memory write of the form:"+              , show (C.ppWrite w)+              ]++computeMemSubstitution ::+  (?logMessage :: String -> IO (), C.IsSymInterface sym) =>+  C.IsSymInterface sym =>+  sym ->+  FixpointRecord p sym ext rtp blocks ->+  C.MemWrites sym ->+  FixpointMonad sym (MemorySubstitution sym)+computeMemSubstitution sym fixpoint_record mem_writes =+ let ?ptrWidth = knownNat @64 in+ do -- widen the memory+    mem_subst_candidate <- liftIO $ constructMemSubstitutionCandidate sym mem_writes++    -- Check the candidate and raise errors if we cannot handle the resulting widening+    res <- liftIO $ runExceptT $+             checkMemSubst sym (fixpointMemSubstitution fixpoint_record)+                               mem_subst_candidate++    case res of+      Left msg -> fail $ unlines $+        [ "SimpleLoopInvariant: failure constructing memory footprint for loop invariant"+        , msg+        ]+      Right x  -> return x+++-- | This function checks that the computed candidate memory substitution is an acceptable+--   refinement of the original. For the moment, this is a very restrictive test; either+--   we have started with an empty substitution (e.g., on the first iteration), or we have+--   computed a substitution that is exactly compatible with the one we started with.+--+--   At some point, it may be necessary or desirable to allow more.+--+--   Note:, for this check we do not need to compare the identities of the actual join variables+--   found in the substitution, just that the memory regions (positions and sizes) are equal.+checkMemSubst :: forall sym.+  W4.IsSymExprBuilder sym =>+  sym ->+  MemorySubstitution sym ->+  MemorySubstitution sym ->+  ExceptT String IO (MemorySubstitution sym)+checkMemSubst sym orig candidate =+  if Map.null (memSubst orig)+    then return candidate+    else do checkCandidateEqual+            return orig++ where+   checkEqualMaps str f m1 m2 =+     do unless (Map.keysSet m1 == Map.keysSet m2)+               (throwError ("Key sets differ when checking " ++ str))+        forM_ (Map.assocs m1) $ \ (k,e1) ->+               case Map.lookup k m2 of+                 Just e2 -> f k e1 e2+                 Nothing -> throwError ("Key sets differ when checking " ++ str)++   checkCandidateEqual =+     checkEqualMaps "memory substitution" checkMBD+       (memSubst orig) (memSubst candidate)++   checkBVEq :: (1 <= w) => W4.SymBV sym w -> W4.SymBV sym w -> IO Bool+   checkBVEq x y =+      do diff <- W4.bvSub sym x y+         case BV.asUnsigned <$> W4.asBV diff of+           Just 0 -> return True+           _      -> return False++   checkMBD n (RegularBlock b1 rmap1) (RegularBlock b2 rmap2) =+      do ok <- liftIO $ checkBVEq b1 b2+         unless ok $ throwError $+               unlines  ["base pointers differ for region " ++ show n+                        , show (W4.printSymExpr b1)+                        , show (W4.printSymExpr b2)+                        ]+         checkEqualMaps ("region map for " ++ show n) (checkMemRegion n) rmap1 rmap2+   checkMBD n (ArrayBlock _a1 l1) (ArrayBlock _a2 l2) =+      do ok <- liftIO $ checkBVEq l1 l2+         unless ok $ throwError $+             unlines [ "array lengths differ for region " ++ show n+                     , show (W4.printSymExpr l1)+                     , show (W4.printSymExpr l2)+                     ]+   checkMBD n _ _ =+      throwError ("Regular block incompatible with array block in region " ++ show n)++   checkMemRegion :: Natural -> Natural -> MemoryRegion sym -> MemoryRegion sym -> ExceptT String IO ()+   checkMemRegion n o r1 r2 =+     do unless (regionOffset r1 == regionOffset r2)+               (throwError ("region offsets differ in region " ++ show n ++ " at " ++ show o))+        unless (regionSize r1 == regionSize r2)+               (throwError ("region sizes differ in region " ++ show n ++ " at " ++ show o))+        unless (regionStorage r1 == regionStorage r2)+               (throwError ("region storage types differ in region " ++ show n ++ " at " ++ show o))++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 C.PausedFrame{ resume = resume } = case resume of+  C.ContinueResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id+  C.CheckMergeResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id+  _ -> NothingPausedFrameTgtId
+ src/Lang/Crucible/LLVM/SymIO.hs view
@@ -0,0 +1,619 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.SymIO+-- Description      : Exporting SymbolicIO operations as Override templates+-- Copyright        : (c) Galois, Inc 2020+-- License          : BSD3+-- Maintainer       : Daniel Matichuk <dmatichuk@galois.com>+-- Stability        : provisional+--+--+-- This module wraps the crucible-symio interface suitably for use within the+-- LLVM frontend to crucible. It provides overrides for the following functions:+--+--   * @open@+--   * @read@+--   * @write@+--   * @close@+--+-- as specified by POSIX. Note that it does not yet cover the C stdio functions.+-- This additional layer on top of crucible-symio is necessary to bridge the gap+-- between LLVMPointer arguments and more primitive argument types (including+-- that filenames need to be read from the LLVM memory model before they can be+-- interpreted).+--+-- The limitations of this library are enumerated in the README for crux-llvm,+-- which is the user-facing documentation for this functionality.+------------------------------------------------------------------------+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Lang.Crucible.LLVM.SymIO+  ( -- * Types+    llvmSymIOIntrinsicTypes+  , LLVMFileSystem(..)+  , SomeOverrideSim(..)+  , initialLLVMFileSystem+  -- * Overrides+  , symio_overrides+  , openFile+  , callOpenFile+  , closeFile+  , callCloseFile+  , readFileHandle+  , callReadFileHandle+  , writeFileHandle+  , callWriteFileHandle+  -- * File-related utilities+  , allocateFileDescriptor+  , lookupFileHandle+  )+  where++import           Control.Monad ( forM, foldM, when )+import           Control.Monad.IO.Class (liftIO)+import qualified Data.BitVector.Sized as BVS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Foldable as F+import qualified Data.Map as Map+import qualified Data.Parameterized.Classes as PC+import           Data.Parameterized.Context+                   ( pattern (:>), pattern Empty, (::>), EmptyCtx, uncurryAssignment )+import qualified Data.Parameterized.Map as MapF+import qualified Data.Parameterized.NatRepr as PN+import qualified Data.Parameterized.SymbolRepr as PS+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import qualified Data.Text.IO as Text.IO+import           GHC.Natural ( Natural )+import           GHC.TypeNats ( type (<=) )+import qualified System.IO as IO++import qualified Lang.Crucible.FunctionHandle as LCF+import           Lang.Crucible.Types ( IntrinsicType, BVType, TypeRepr(..) )+import qualified Lang.Crucible.Utils.MuxTree as CMT+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Backend as C+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.Intrinsics+import           Lang.Crucible.Simulator.RegMap+import qualified Lang.Crucible.Simulator.GlobalState as LCSG++import           Lang.Crucible.LLVM.Bytes (toBytes)+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.Extension ( ArchWidth )+import           Lang.Crucible.LLVM.DataLayout ( noAlignment )+import           Lang.Crucible.LLVM.Intrinsics+import           Lang.Crucible.LLVM.QQ( llvmOvr )++import qualified What4.Interface as W4+import qualified What4.Partial as W4P++import qualified Lang.Crucible.SymIO as SymIO++-- | A representation of the filesystem for the LLVM frontend+--+-- This contains the underlying SymIO filesystem as well as the infrastructure+-- for allocating fresh file handles+data LLVMFileSystem ptrW =+  LLVMFileSystem+    { llvmFileSystem :: GlobalVar (SymIO.FileSystemType ptrW)+    -- ^ The underlying symbolic filesystem+    , llvmFileDescMap :: GlobalVar (FDescMapType ptrW)+    -- ^ Maintains the mapping from file descriptors to low-level crucible-symio+    -- 'SymIO.FileHandle's+    , llvmHandles :: Map.Map Natural IO.Handle+    -- ^ Handles that concrete output will be mirrored to; if this is empty, no+    -- mirroring will be performed+    , llvmFilePointerRepr :: PN.NatRepr ptrW+    }++-- | Contains the mapping from file descriptors to the underlying 'SymIO.FileHandle'+--+-- This also tracks the next file descriptor to hand out.  See Note [File+-- Descriptor Sequence].+data FDescMap sym ptrW where+  FDescMap ::+    { fDescNext :: Natural+    -- ^ The next file descriptor to hand out+    --+    -- Note that these are truncated to 32 bit bitvectors when they are handed+    -- out; we don't have any guards against overflow on that right now+    , fDescMap :: Map.Map Natural (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW))+    } -> FDescMap sym ptrW++-- | A wrapper around a RankN 'OverrideSim' action+--+-- This enables us to make explicit that all of the type variables are free and+-- can be instantiated at any types since this override action has to be+-- returned from the 'initialLLVMFileSystem' function.+newtype SomeOverrideSim sym a where+  SomeOverrideSim :: (forall p ext rtp args ret . OverrideSim p sym ext rtp args ret a) -> SomeOverrideSim sym a++targetToFD :: SymIO.FDTarget k -> Maybe Natural+targetToFD t =+  case t of+    SymIO.StdinTarget -> Just 0+    SymIO.StdoutTarget -> Just 1+    SymIO.StderrTarget -> Just 2+    _ -> Nothing++-- | Create an initial 'LLVMFileSystem' based on given concrete and symbolic file contents+--+-- Note that this function takes a 'LCSG.SymGlobalState' because it needs to+-- allocate a few distinguished global variables for its own bookkeeping. It+-- adds them to the given global state and returns an updated global state,+-- which must not be discarded.+--+-- The returned 'LLVMFileSystem' is a wrapper around that global state, and is+-- required to initialize the symbolic I/O overrides.+--+-- This function also returns an 'OverrideSim' action (wrapped in a+-- 'SomeOverrideSim') that must be run to initialize any standard IO file+-- descriptors that have been requested.  This action should be run *before* the+-- entry point of the function that is being verified is invoked.+--+-- See Note [Standard IO Setup] for details+initialLLVMFileSystem+  :: forall sym ptrW+   . (HasPtrWidth ptrW, C.IsSymInterface sym)+  => LCF.HandleAllocator+  -> sym+  -> PN.NatRepr ptrW+  -- ^ The pointer width for the platform+  -> SymIO.InitialFileSystemContents sym+  -- ^ The initial contents of the symbolic filesystem+  -> [(SymIO.FDTarget SymIO.Out, IO.Handle)]+  -- ^ A mapping from file targets to handles, to which output should be+  -- mirrored. This is intended to support mirroring symbolic stdout/stderr to+  -- concrete stdout/stderr, but could be more flexible in the future (e.g.,+  -- handling sockets).+  --+  -- Note that the writes to the associated underlying symbolic files are still+  -- recorded in the symbolic filesystem+  -> LCSG.SymGlobalState sym+  -- ^ The current globals, which will be updated with necessary bindings to support the filesystem+  -> IO (LLVMFileSystem ptrW, LCSG.SymGlobalState sym, SomeOverrideSim sym ())+initialLLVMFileSystem halloc sym ptrW initContents handles globals0 = do+  fs0 <- SymIO.initFS sym ptrW initContents+  let fdm0 = FDescMap { fDescNext = 0+                      , fDescMap = Map.empty+                      }+  fsVar <- freshGlobalVar halloc (Text.pack "llvmFileSystem_Global") (SymIO.FileSystemRepr ptrW)+  fdmVar <- freshGlobalVar halloc (Text.pack "llvmFileDescMap_Global") (FDescMapRepr ptrW)+  let llfs = LLVMFileSystem { llvmFileSystem = fsVar+                            , llvmFileDescMap = fdmVar+                            , llvmFilePointerRepr = ptrW+                            , llvmHandles = Map.fromList [ (fd, hdl)+                                                         | (tgt, hdl) <- handles+                                                         , Just fd <- return (targetToFD tgt)+                                                         ]+                            }+  let globals1 = LCSG.insertGlobal fdmVar fdm0 $ LCSG.insertGlobal fsVar fs0 globals0+  let bootstrapStdio :: OverrideSim p sym ext rtp args ret ()+      bootstrapStdio = do+        -- Allocate the file handles for the standard IO streams in order such+        -- that they are in file descriptors 0, 1, and 2 respectively+        --+        -- We discard the actual file descriptors because they are accessed via+        -- literals in the program.  The 'allocateFileDescriptor' function+        -- handles mapping the underlying FileHandle to an int file descriptor+        -- internally.+        let toLit = W4.Char8Literal . TextEncoding.encodeUtf8 . SymIO.fdTargetToText+        when (Map.member SymIO.StdinTarget (SymIO.concreteFiles initContents) || Map.member SymIO.StdinTarget (SymIO.symbolicFiles initContents)) $ do+          stdinFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StdinTarget)+          _inFD <- SymIO.openFile' fsVar stdinFilename >>= allocateFileDescriptor llfs+          return ()+        when (SymIO.useStdout initContents) $ do+          stdoutFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StdoutTarget)+          _outFD <- SymIO.openFile' fsVar stdoutFilename >>= allocateFileDescriptor llfs+          return ()+        when (SymIO.useStderr initContents) $ do+          stderrFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StderrTarget)+          _errFD <- SymIO.openFile' fsVar stderrFilename >>= allocateFileDescriptor llfs+          return ()++  return (llfs, globals1, SomeOverrideSim bootstrapStdio)++type FDescMapType w = IntrinsicType "LLVM_fdescmap" (EmptyCtx ::> BVType w)++instance (IsSymInterface sym) => IntrinsicClass sym "LLVM_fdescmap" where+  type Intrinsic sym "LLVM_fdescmap" (EmptyCtx ::> BVType w) = FDescMap sym w++  muxIntrinsic sym _iTypes _nm (Empty :> (BVRepr _w)) = muxFDescMap sym+  muxIntrinsic _ _ nm ctx = \_ _ _ -> typeError nm ctx++pattern FDescMapRepr :: () => (1 <= w, ty ~ FDescMapType w) => PN.NatRepr w -> TypeRepr ty+pattern FDescMapRepr w <- IntrinsicRepr (PC.testEquality (PS.knownSymbol @"LLVM_fdescmap") -> Just PC.Refl) (Empty :> BVRepr w)+  where+    FDescMapRepr w = IntrinsicRepr PS.knownSymbol (Empty :> BVRepr w)++muxFDescMap+  :: IsSymInterface sym+  => sym+  -> W4.Pred sym+  -> FDescMap sym ptrW+  -> FDescMap sym ptrW+  -> IO (FDescMap sym ptrW)+muxFDescMap sym p (FDescMap nextT mapT) (FDescMap nextF mapF) = do+  let+    keys = Set.toList $ Set.union (Map.keysSet mapT) (Map.keysSet mapF)+    next = max nextT nextF+  fmap (FDescMap next . Map.fromList) $ forM keys $ \k -> do+    let vT = W4P.joinMaybePE (Map.lookup k mapT)+    let vF = W4P.joinMaybePE (Map.lookup k mapF)+    r <- mergePartExpr sym (CMT.mergeMuxTree sym) p vT vF+    return (k,r)++-- | The intrinsics supporting symbolic I/O in LLVM+--+-- Note that this includes the base intrinsic types from crucible-symio, so+-- those do not need to be added again.+llvmSymIOIntrinsicTypes :: IsSymInterface sym => IntrinsicTypes sym+llvmSymIOIntrinsicTypes = id+  . MapF.insert (PS.knownSymbol :: PS.SymbolRepr "LLVM_fdescmap") IntrinsicMuxFn+  $ SymIO.symIOIntrinsicTypes++-- | Resolve a symbolic file descriptor to a known allocated file handle.+-- The partial result is undefined if the descriptor is not found in the+-- file handle table.+getHandle+  :: forall sym ptrW+   . IsSymInterface sym+  => sym+  -> W4.SymBV sym 32+  -> FDescMap sym ptrW+  -> IO (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW))+getHandle sym fdesc (FDescMap _ m) = case W4.asBV fdesc of+  Just fdesc_lit | Just fhdl <- Map.lookup (BVS.asNatural fdesc_lit) m -> return fhdl+  _ -> do+    cases <- mapM go (Map.assocs m)+    foldM (\a (p, b) -> mergePartExpr sym (CMT.mergeMuxTree sym) p b a) W4P.Unassigned cases+  where+    go :: (Natural, (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW)))+       -> IO (W4.Pred sym, (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW)))+    go (n, fhdl) = do+      n_sym <- W4.bvLit sym PN.knownNat (BVS.mkBV PN.knownNat (toInteger n))+      fdesc_eq <- W4.bvEq sym n_sym fdesc+      return $ (fdesc_eq, fhdl)++-- | Construct a 'SymIO.DataChunk' from a pointer+--+-- Note that this is a lazy construct that does not load memory immediately. An+-- 'SymIO.DataChunk' is a wrapper around a function to peek memory at a given+-- offset one byte at a time.+chunkFromMemory+  :: forall sym bak wptr+   . (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions)+  => bak+  -> MemImpl sym+  -> LLVMPtr sym wptr+  -> IO (SymIO.DataChunk sym wptr)+chunkFromMemory bak mem ptr =+  let sym = backendGetSym bak in+  SymIO.mkArrayChunk sym $ \offset -> do+    ptr' <- ptrAdd sym PtrWidth ptr offset+    llbytes <- doLoad bak mem ptr' (bitvectorType (toBytes (1 :: Integer))) (LLVMPointerRepr (PN.knownNat @8)) noAlignment+    projectLLVM_bv bak llbytes++-- | Retrieve the 'SymIO.FileHandle' that the given descriptor represents,+-- calling the continuation with 'Nothing' if the descriptor does not represent+-- a valid handle. Notably, a successfully resolved handle may itself still be closed.+--+-- Note that the continuation may be called multiple times if it is used within+-- a symbolic branch. As a result, any side effects in the continuation may be+-- performed multiple times.+lookupFileHandle+  :: IsSymInterface sym+  => LLVMFileSystem wptr+  -> W4.SymBV sym 32+  -> RegMap sym args''+  -> (forall args'. Maybe (SymIO.FileHandle sym wptr) -> RegMap sym args'' -> OverrideSim p sym ext r args' ret a)+  -> OverrideSim p sym ext r args ret a+lookupFileHandle fsVars fdesc args cont = do+  descMap <- readGlobal (llvmFileDescMap fsVars)+  sym <- getSymInterface+  (liftIO $ getHandle sym fdesc descMap) >>= \case+    W4P.PE p fhdl -> do+      symbolicBranch p+        args (getOverrideArgs >>= \args' -> cont (Just fhdl) args') Nothing+        args (getOverrideArgs >>= \args' -> cont Nothing args') Nothing+    W4P.Unassigned -> cont Nothing args+++-- | Allocate a fresh (integer/bitvector(32)) file descriptor that is associated with the given 'SymIO.FileHandle'+--+-- NOTE that this is a file descriptor in the POSIX sense, rather than a @FILE*@+-- or the underlying 'SymIO.FileHandle'.+--+-- NOTE that we truncate the file descriptor source to 32 bits in this function;+-- it could in theory overflow.+--+-- NOTE that the file descriptor counter is incremented monotonically as the+-- simulator hits calls to @open@; this means that calls to @open@ in parallel+-- control flow branches would get sequential file descriptor values whereas the+-- real program would likely allocate the same file descriptor value on both+-- branches. This could be relevant for some bug finding scenarios.+--+-- TODO It would be interesting if we could add a symbolic offset to these+-- values so that we can't make any concrete assertions about them. It isn't+-- clear if that ever happens in real code. If we do that, we need an escape+-- hatch to let us allocate file descriptors 0, 1, and 2 if needed.+allocateFileDescriptor+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMFileSystem wptr+  -> SymIO.FileHandle sym wptr+  -> OverrideSim p sym ext r args ret (W4.SymBV sym 32)+allocateFileDescriptor fsVars fh = do+  sym <- getSymInterface+  modifyGlobal (llvmFileDescMap fsVars) $ \(FDescMap next descMap) -> do+    fdesc <-  liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) (toInteger next))+    let ptrMap' = Map.insert next (W4P.justPartExpr sym fh) descMap+    return (fdesc, FDescMap (next + 1) ptrMap')++loadFileIdent+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions)+  => GlobalVar Mem+  -> LLVMPtr sym wptr+  -> OverrideSim p sym ext r args ret (SymIO.FileIdent sym)+loadFileIdent memOps filename_ptr =+  ovrWithBackend $ \bak ->+   do mem <- readGlobal memOps+      filename_bytes <- liftIO $ loadString bak mem filename_ptr Nothing+      liftIO $ W4.stringLit (backendGetSym bak) (W4.Char8Literal (BS.pack filename_bytes))++returnIOError32+  :: IsSymInterface sym+  => OverrideSim p sym ext r args ret (W4.SymBV sym 32)+returnIOError32 = do+  sym <- getSymInterface+  liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) (-1))++returnIOError+  :: forall wptr p sym ext r args ret+  . (IsSymInterface sym, HasPtrWidth wptr)+  => OverrideSim p sym ext r args ret (W4.SymBV sym wptr)+returnIOError = do+  sym <- getSymInterface+  liftIO $ W4.bvLit sym PtrWidth (BVS.mkBV PtrWidth (-1))++openFile+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions)+  => LLVMFileSystem wptr+  -> LLVMOverride p sym+           (EmptyCtx ::> LLVMPointerType wptr+                     ::> BVType 32)+           (BVType 32)+openFile fsVars =+  [llvmOvr| i32 @open( i8*, i32 ) |]+  -- TODO add mode support by making this a varargs function+  (\memOps bak args -> uncurryAssignment (callOpenFile bak memOps fsVars) args)++callOpenFile ::+  (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) =>+  bak ->+  GlobalVar Mem ->+  LLVMFileSystem wptr ->+  RegEntry sym (LLVMPointerType wptr) ->+  RegEntry sym (BVType 32) ->+  OverrideSim p sym ext rtp args ret (RegValue sym (BVType 32))+callOpenFile _bak memOps fsVars filename_ptr _flags =+  do fileIdent <- loadFileIdent memOps (regValue filename_ptr)+     SymIO.openFile (llvmFileSystem fsVars) fileIdent $ \case+       Left SymIO.FileNotFound -> returnIOError32+       Right fileHandle -> allocateFileDescriptor fsVars fileHandle++closeFile+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMFileSystem wptr+  -> LLVMOverride p sym+           (EmptyCtx ::> BVType 32)+           (BVType 32)+closeFile fsVars =+  [llvmOvr| i32 @close( i32 ) |]+  (\memOps bak args -> uncurryAssignment (callCloseFile bak memOps fsVars) args)++callCloseFile ::+  (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) =>+  bak ->+  GlobalVar Mem ->+  LLVMFileSystem wptr ->+  RegEntry sym (BVType 32) ->+  OverrideSim p sym ext rtp args ret (RegValue sym (BVType 32))+callCloseFile bak _memOps fsVars filedesc =+  do let sym = backendGetSym bak+     lookupFileHandle fsVars (regValue filedesc) emptyRegMap $ \case+       Just fileHandle -> \_ ->+         SymIO.closeFileHandle (llvmFileSystem fsVars) fileHandle $ \case+           Just SymIO.FileHandleClosed -> returnIOError32+           Nothing -> liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) 0)+       Nothing -> \_ -> returnIOError32++readFileHandle+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMFileSystem wptr+  -> LLVMOverride p sym+           (EmptyCtx ::> BVType 32+                     ::> LLVMPointerType wptr+                     ::> BVType wptr)+           (BVType wptr)+readFileHandle fsVars =+  [llvmOvr| ssize_t @read( i32, i8*, size_t ) |]+  (\memOps bak args -> uncurryAssignment (callReadFileHandle bak memOps fsVars) args)++callReadFileHandle ::+  (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) =>+  bak ->+  GlobalVar Mem ->+  LLVMFileSystem wptr ->+  RegEntry sym (BVType 32) ->+  RegEntry sym (LLVMPointerType wptr) ->+  RegEntry sym (BVType wptr) ->+  OverrideSim p sym ext rtp args ret (RegValue sym (BVType wptr))+callReadFileHandle bak memOps fsVars filedesc buf count =+  do let sym = backendGetSym bak+     let args = Empty :> filedesc :> buf :> count+     lookupFileHandle fsVars (regValue filedesc) (RegMap args) $ \case+       Just fileHandle -> \(RegMap (Empty :> _ :> buffer_ptr :> size)) ->+         SymIO.readChunk (llvmFileSystem fsVars) fileHandle (regValue size) $ \case+           Left SymIO.FileHandleClosed -> returnIOError+           Right (chunk, bytesRead) -> do+             modifyGlobal memOps $ \mem -> liftIO $ do+               chunkArray <- SymIO.chunkToArray sym (W4.BaseBVRepr PtrWidth) chunk+               mem' <- doArrayStore bak mem (regValue buffer_ptr) noAlignment chunkArray bytesRead+               return (bytesRead, mem')+       Nothing -> \_ -> returnIOError++-- | If the write is to a concrete FD for which we have an associated 'IO.Handle', mirror the write to that Handle+--+-- This is intended to support mirroring stdout/stderr in a user-visible way+-- (noting that symbolic IO can be repeated due to the simulator branching).+-- Note also that only writes of a concrete length are mirrored reasonably;+-- writes with symbolic length are denoted with a substitute token. Likewise+-- individual symbolic bytes are printed as @?@ characters.+doConcreteWrite+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => PN.NatRepr wptr+  -> Map.Map Natural IO.Handle+  -> RegValue sym (BVType 32)+  -> SymIO.DataChunk sym wptr+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext rtp args ret ()+doConcreteWrite ptrw handles symFD chunk size =+  case W4.asBV symFD of+    Just (BVS.asNatural -> fd)+      | Just hdl <- Map.lookup fd handles+      , Just numBytes <- BVS.asUnsigned <$> W4.asBV (regValue size) -> do+          -- We have a concrete size of the write and an IO Handle to write+          -- to. Write each byte that is concrete, or replace it with a '?'+          sym <- getSymInterface+          F.forM_ [0..numBytes - 1] $ \idx -> do+            idxBV <- liftIO $ W4.bvLit sym ptrw (BVS.mkBV ptrw idx)+            byteVal <- liftIO $ SymIO.evalChunk chunk idxBV+            case W4.asBV byteVal of+              Just (BVS.asUnsigned -> concByte) -> liftIO $ BS.hPut hdl (BS.pack [fromIntegral concByte])+              Nothing -> liftIO $ BS.hPut hdl (BSC.pack ['?'])+      | Just hdl <- Map.lookup fd handles -> do+          -- In this case, we have a write of symbolic size.  We can't really+          -- write that out, but do our best+          liftIO $ Text.IO.hPutStr hdl (Text.pack "[‽]")+    _ -> return ()++writeFileHandle+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions)+  => LLVMFileSystem wptr+  -> LLVMOverride p sym+           (EmptyCtx ::> BVType 32+                     ::> LLVMPointerType wptr+                     ::> BVType wptr)+           (BVType wptr)+writeFileHandle fsVars =+  [llvmOvr| ssize_t @write( i32, i8*, size_t ) |]+  (\memOps bak args -> uncurryAssignment (callWriteFileHandle bak memOps fsVars) args)++callWriteFileHandle ::+  (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) =>+  bak ->+  GlobalVar Mem ->+  LLVMFileSystem wptr ->+  RegEntry sym (BVType 32) ->+  RegEntry sym (LLVMPointerType wptr) ->+  RegEntry sym (BVType wptr) ->+  OverrideSim p sym ext rtp args ret (RegValue sym (BVType wptr))+callWriteFileHandle bak memOps fsVars filedesc buf count =+  do let args = Empty :> filedesc :> buf :> count+     lookupFileHandle fsVars (regValue filedesc) (RegMap args) $ \case+       Just fileHandle -> \(RegMap (Empty :> _ :> buffer_ptr :> size)) -> do+         mem <- readGlobal memOps+         chunk <- liftIO $ chunkFromMemory bak mem (regValue buffer_ptr)+         doConcreteWrite (llvmFilePointerRepr fsVars) (llvmHandles fsVars) (regValue filedesc) chunk size+         SymIO.writeChunk (llvmFileSystem fsVars) fileHandle chunk (regValue size) $ \case+           Left SymIO.FileHandleClosed -> returnIOError+           Right bytesWritten -> return bytesWritten+       Nothing -> \_ -> returnIOError++-- | The file handling overrides+--+-- See the 'initialLLVMFileSystem' function for creating the initial filesystem state+symio_overrides+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?memOpts :: MemOptions)+  => LLVMFileSystem wptr+  -> [OverrideTemplate p sym arch rtp l a]+symio_overrides fs =+  [ basic_llvm_override $ openFile fs+  , basic_llvm_override $ closeFile fs+  , basic_llvm_override $ readFileHandle fs+  , basic_llvm_override $ writeFileHandle fs+  ]++{- Note [Standard IO Setup]++The underlying symbolic IO library hands out abstract 'FileHande's, which are an+internal type that do not correspond to any source-level data values.  Frontends+must map them to something from the target programming language.  In this+module, that means we must map them to POSIX file descriptors (represented as C+ints).++In particular, when setting up the symbolic execution engine, we want to be able+to map standard input, standard output, and standard error to their prescribed+file descriptors (0, 1, and 2 respectively).  We can do that by simply+allocating them in order, as we start the file descriptor counter at 0 (see+'FDescMap').  Note that we just reuse the existing infrastructure to allocate+file descriptors (in particular, 'allocateFileDescriptor'). Note that we do+*not* use the 'openFile' function defined in this module because it expects the+filename to be stored in the LLVM memory, which our magic names for the standard+streams are not.++Note that if we start the symbolic execution engine without standard+in/out/error, we could potentially hand out file descriptors at these usually+reserved numbers. That isn't necessarily a problem, but it could be. We could+one day provide a method for forcing file descriptors to start at 3 even if+these special files are not allocated (i.e., start off closed).  We should+investigate the behavior of the OS and mimic it (or make it an option).++As a note on file names, the standard IO streams do not have prescribed names+that can be opened. We use synthetic names defined in the underlying+architecture-independent symbolic IO library.  We do not need to know what they+are here, but they are arranged to not collide with any valid names for actual+files in the symbolic filesystem.++-}++{- Note [File Descriptor Sequence]++This code uses a global counter to provide the next file descriptor to hand out+when a file is opened.  This can lead to a subtle difference in behavior+compared to a real program.++Consider the case where a program contains a symbolic branch where both branches+open files.  The symbolic I/O system will allocate each of the opened files a+different file descriptor.  In contrast, a real system would only assign one of+those file descriptors because it would only see one branch.  This means that+later opened files would differ from the real program.++This should only be observable if the program makes control decisions based on+the values in file descriptors, which it really should not. However, it is+possible in the real world.++-}
+ src/Lang/Crucible/LLVM/Translation.hs view
@@ -0,0 +1,544 @@+-- |+-- Module           : Lang.Crucible.LLVM.Translation+-- Description      : Translation of LLVM AST into Crucible control-flow graph+-- Copyright        : (c) Galois, Inc 2014-2021+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- This module translates an LLVM 'Module' into a collection of Crucible+-- control-flow graphs, one per function.  The tricky parts of this translation+-- are 1) mapping LLVM types onto Crucible types in a sensible way and 2)+-- translating the phi-instructions of LLVM's SSA form.+--+-- To handle the translation of phi-functions, we first perform a+-- pre-pass over all the LLVM basic blocks looking for phi-functions+-- and build a datastructure that tells us what assignments to make+-- when jumping from block l to block l'.  We then emit instructions+-- to make these assignments in a separate Crucible basic block (see+-- 'definePhiBlock').  Thus, the translated CFG will generally have+-- more basic blocks than the original LLVM.+--+-- Points of note:+--+--  * Immediate (i.e., not in memory) structs and packed structs are translated the same.+--  * Undefined values generate special Crucible expressions (e.g., BVUndef) to+--     represent arbitrary bitpatterns.+--  * The floating-point domain is interpreted by IsSymInterface as either+--    the IEEE754 floating-point domain, the real domain, or a domain with+--    bitvector values and uninterpreted operations.+--+-- Some notes on undefined/poison values: (outcome of discussions between JHx and RWD)+--+-- * Continue to add Crucible expressions for undefined values as+-- required (e.g. for floating-point values).  Crucible itself is+-- currently treating undefined values as fresh symbolic inputs; it+-- should instead invent a new category of "arbitrary" values that get+-- passed down into the solvers in a way that is dependent on the task+-- at hand.  For example, in verification tasks, it is appropriate to+-- treat the arbitrary values the same as symbolic inputs.  However,+-- for preimage-finding tasks, the arbitrary values must be treated as+-- universally-quantified, unlike the symbolic inputs which are+-- existentially-quantified.+--+-- * For poison values, our implementation strategy is to assert+-- side conditions onto values that may create poison.  As opposed+-- to assertions (which must be satisfied because you passed through+-- a control-flow point) side conditions are intended to mean that+-- a condition must hold when a value is used (i.e., side conditions+-- follow data-flow).  So if a poison value is created but not examined+-- (e.g., because we later do a test to determine if the value is safe),+-- that should be allowed.+--+-- A (probably) partial list of things we intend to support, but do not yet:+--+--  * Various vector instructions. This includes a variety of instructions+--      that LLVM allows to take vector arguments, but are currently only+--      defined on scalar (nonvector) arguments. (Progress has been made on+--      this, but may not yet be complete).+--+-- A list of things that are unsupported and may never be:+--+--  * Computed jumps and blockaddress expressions+--  * Multithreading primitives+--  * Alternate calling conventions+------------------------------------------------------------------------++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++module Lang.Crucible.LLVM.Translation+  ( ModuleTranslation+  , getTranslatedCFG+  , getTranslatedFnHandle+  , transContext+  , globalInitMap+  , modTransDefs+  , modTransModule+  , modTransHalloc+  , LLVMContext(..)+  , llvmTypeCtx+  , translateModule+  , LLVMTranslationWarning(..)++  , module Lang.Crucible.LLVM.Translation.Constant+  , module Lang.Crucible.LLVM.Translation.Options+  , module Lang.Crucible.LLVM.Translation.Types+  ) where++import           Control.Lens hiding (op, (:>) )+import           Control.Monad (foldM)+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Maybe+import           Data.String+import qualified Data.Text   as Text+import           Prettyprinter (pretty)++import qualified Text.LLVM.AST as L++import           Data.Parameterized.NatRepr as NatRepr+import           Data.Parameterized.Some+import           Data.Parameterized.Nonce++import           What4.FunctionName+import           What4.ProgramLoc++import qualified Lang.Crucible.CFG.Core as C+import           Lang.Crucible.CFG.Generator+import           Lang.Crucible.CFG.SSAConversion( toSSA )++import           Lang.Crucible.FunctionHandle+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.Globals+import           Lang.Crucible.LLVM.MemModel+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import           Lang.Crucible.LLVM.Translation.Aliases+import           Lang.Crucible.LLVM.Translation.Constant+import           Lang.Crucible.LLVM.Translation.Expr+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Options+import           Lang.Crucible.LLVM.Translation.Instruction+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.Types+++------------------------------------------------------------------------+-- Translation results++type ModuleCFGMap = Map L.Symbol CFGMapEntry++data CFGMapEntry+  = TranslatedCFG L.Declare (C.AnyCFG LLVM)+  | UntranslatedCFG L.Define SomeHandle++-- | The result of translating an LLVM module into Crucible CFGs.+data ModuleTranslation arch+   = ModuleTranslation+      { _cfgMap        :: IORef ModuleCFGMap+      , _transContext :: LLVMContext arch+      , _globalInitMap :: GlobalInitializerMap+        -- ^ A map from global names to their (constant) values+        -- Note: Willy-nilly global initialization may be unsound in the+        -- presence of compositional verification.+      , _modTransNonce :: !(Nonce GlobalNonceGenerator arch)+        -- ^ For a reasonably quick 'testEquality' instance+      , _modTransDefs :: ![(L.Declare, SomeHandle)]+        -- ^ A collection of declarations for all the functions+        --   defined in this module.+      , _modTransHalloc :: HandleAllocator+      , _modTransModule :: L.Module+      , _modTransOpts   :: TranslationOptions+      }++instance TestEquality ModuleTranslation where+  testEquality mt1 mt2 =+    testEquality (_modTransNonce mt1) (_modTransNonce mt2)++transContext :: Getter (ModuleTranslation arch) (LLVMContext arch)+transContext = to _transContext++globalInitMap :: Getter (ModuleTranslation arch) GlobalInitializerMap+globalInitMap = to _globalInitMap++modTransDefs :: Getter (ModuleTranslation arch) [(L.Declare,SomeHandle)]+modTransDefs = to _modTransDefs++modTransModule :: Getter (ModuleTranslation arch) L.Module+modTransModule = to _modTransModule++modTransHalloc :: Getter (ModuleTranslation arch) HandleAllocator+modTransHalloc = to _modTransHalloc++typeToRegExpr :: MemType -> LLVMGenerator s arch ret (Some (Reg s))+typeToRegExpr tp = do+  llvmTypeAsRepr tp $ \tpr ->+    Some <$> newUnassignedReg tpr++-- | This function pre-computes the types of all the crucible registers by scanning+--   through each basic block and finding the place where that register is assigned.+--   Because LLVM programs are in SSA form, this will occur in exactly one place.+--   The type of the register is inferred from the instruction that assigns to it+--   and is recorded in the ident map.+buildRegMap :: IdentMap s -> L.Define -> LLVMGenerator s arch reg (IdentMap s)+buildRegMap m d = foldM (\m0 bb -> buildRegTypeMap m0 bb) m $ L.defBody d++buildRegTypeMap :: IdentMap s+                -> L.BasicBlock+                -> LLVMGenerator s arch ret (IdentMap s)+buildRegTypeMap m0 bb = foldM stmt m0 (L.bbStmts bb)+ where+    err instr msg =+       malformedLLVMModule "Invalid type in instruction result"+          [ fromString (showInstr instr)+          , fromString msg+          ]++    stmt m (L.Effect _ _) = return m+    stmt m (L.Result ident instr _) = do+         ty <- either (err instr) return $ instrResultType instr+         ex <- typeToRegExpr ty+         case Map.lookup ident m of+           Just _ ->+             malformedLLVMModule "Register not used in SSA fashion"+              [ fromString (show ident)+              , fromString (showInstr instr)+              ]+           Nothing -> return $ Map.insert ident (Left ex) m+++-- | Generate crucible code for each LLVM statement in turn.+generateStmts :: (?transOpts :: TranslationOptions)+        => TypeRepr ret+        -> L.BlockLabel+        -> Set L.Ident {- ^ Set of usable identifiers -}+        -> [L.Stmt]+        -> LLVMGenerator s arch ret a+generateStmts retType lab defSet0 stmts = go defSet0 (processDbgDeclare stmts)+ where go _ [] = fail "LLVM basic block ended without a terminating instruction"+       go defSet (x:xs) =+         case x of+           -- a result statement assigns the result of the instruction into a register+           L.Result ident instr md ->+              do setLocation md+                 generateInstr retType lab defSet instr+                   (assignLLVMReg ident)+                   (go (Set.insert ident defSet) xs)++           -- an effect statement simply executes the instruction for its effects and discards the result+           L.Effect instr md ->+              do setLocation md+                 generateInstr retType lab defSet instr+                   (\_ -> return ())+                   (go defSet xs)++-- | Search for calls to intrinsic 'llvm.dbg.declare' and copy the+-- metadata onto the corresponding 'alloca' statement.  Also copy+-- metadata backwards from 'bitcast' statements toward 'alloca'.+processDbgDeclare :: [L.Stmt] -> [L.Stmt]+processDbgDeclare = snd . go+  where+    go :: [L.Stmt] -> (Map L.Ident [(String, L.ValMd)] , [L.Stmt])+    go [] = (Map.empty, [])+    go (stmt : stmts) =+      let (m, stmts') = go stmts in+      case stmt of+        L.Result x instr@L.Alloca{} md ->+          case Map.lookup x m of+            Just md' -> (m, L.Result x instr (md' ++ md) : stmts')+            Nothing -> (m, stmt : stmts')+              --error $ "Identifier not found: " ++ show x ++ "\nPossible identifiers: " ++ show (Map.keys m)++        L.Result x (L.Conv L.BitCast (L.Typed _ (L.ValIdent y)) _) md ->+          let md' = md ++ fromMaybe [] (Map.lookup x m)+              m'  = Map.alter (Just . maybe md' (md'++)) y m+           in (m', stmt:stmts)++        L.Effect (L.Call _ _ (L.ValSymbol "llvm.dbg.declare") (L.Typed _ (L.ValMd (L.ValMdValue (L.Typed _ (L.ValIdent x)))) : _)) md ->+          (Map.insert x md m, stmt : stmts')++        -- This is needlessly fragile. Let's just ignore debug declarations we don't understand.+        -- L.Effect (L.Call _ _ (L.ValSymbol "llvm.dbg.declare") args) md ->+        --  error $ "Ill-formed arguments to llvm.dbg.declare: " ++ show (args, md)++        _ -> (m, stmt : stmts')++setLocation+  :: [(String,L.ValMd)]+  -> LLVMGenerator s arch ret ()+setLocation [] = return ()+setLocation (x:xs) =+  case x of+    ("dbg",L.ValMdLoc dl) ->+      let ln   = fromIntegral $ L.dlLine dl+          col  = fromIntegral $ L.dlCol dl+          file = getFile $ L.dlScope dl+       in setPosition (SourcePos file ln col)+    ("dbg",L.ValMdDebugInfo (L.DebugInfoSubprogram subp))+      | Just file' <- L.dispFile subp+      -> let ln = fromIntegral $ L.dispLine subp+             file = getFile file'+          in setPosition (SourcePos file ln 0)+    _ -> setLocation xs++ where+ getFile = Text.pack . maybe "" filenm . findFile++ -- The typical values available here will be something like:+ --+ -- > L.difDirectory = "/home/joeuser/work"+ -- > L.difFilename  = "src/lib/foo.c"+ --+ -- At the present time, only the 'difFilename' is used for the+ -- relative path because combining these to form an absolute path+ -- would cause superfluous result differences (e.g. golden test+ -- failures) and potentially leak information.+ --+ -- The downside is that relative paths may make it harder for various+ -- tools (e.g. emacs) to locate the offending source file.  The+ -- suggested method for handling this is to have the emacs compile+ -- function emit an initial rooted directory location in the proper+ -- syntax, but if this is problematic, a future direction would be to+ -- add a config option to control whether an absolute or a relative+ -- path is desired (defaulting to the latter).+ --+ -- [The previous implementation always generated absolute paths, but+ -- was careful to check if `difFilename` was already absolute.]+ filenm = L.difFilename++findFile :: (?lc :: TypeContext) => L.ValMd -> Maybe L.DIFile+findFile (L.ValMdRef x) = findFile =<< lookupMetadata x++findFile (L.ValMdNode (_:Just (L.ValMdRef y):_)) =+  case lookupMetadata y of+    Just (L.ValMdNode [Just (L.ValMdString fname), Just (L.ValMdString fpath)]) ->+        Just (L.DIFile fname fpath)+    _ -> Nothing++findFile (L.ValMdDebugInfo di) =+  case di of+    L.DebugInfoFile dif -> Just dif+    L.DebugInfoLexicalBlock dilex+      | Just md <- L.dilbFile dilex -> findFile md+      | Just md <- L.dilbScope dilex -> findFile md+    L.DebugInfoLexicalBlockFile dilexFile+      | Just md <- L.dilbfFile dilexFile -> findFile md+      | otherwise -> findFile (L.dilbfScope dilexFile)+    L.DebugInfoSubprogram disub+      | Just md <- L.dispFile disub -> findFile md+      | Just md <- L.dispScope disub -> findFile md+    _ -> Nothing++findFile _ = Nothing++-- | Lookup the block info for the given LLVM block and then define a new crucible block+--   by translating the given LLVM statements.+defineLLVMBlock+        :: (?transOpts :: TranslationOptions)+        => TypeRepr ret+        -> LLVMBlockInfoMap s+        -> L.BasicBlock+        -> LLVMGenerator s arch ret ()+defineLLVMBlock retType lm L.BasicBlock{ L.bbLabel = Just lab, L.bbStmts = stmts } = do+  case Map.lookup lab lm of+    Just bi -> defineBlock (block_label bi) (generateStmts retType lab (block_use_set bi) stmts)+    Nothing -> fail $ unwords ["LLVM basic block not found in block info map", show lab]++defineLLVMBlock _ _ _ = fail "LLVM basic block has no label!"++-- | Do some initial preprocessing to find all the phi nodes in the program+--   and to preallocate all the crucible registers we will need based on the LLVM+--   types of all the LLVM registers.  Then translate each LLVM basic block in turn.+--+--   This step introduces a new dummy entry point that simply jumps to the LLVM entry+--   point.  It is inconvenient to avoid doing this when using the Generator interface.+genDefn :: (?transOpts :: TranslationOptions)+        => L.Define+        -> TypeRepr ret+        -> LLVMGenerator s arch ret (Expr ext s ret)+genDefn defn retType =+  case L.defBody defn of+    [] -> fail "LLVM define with no blocks!"+    ( L.BasicBlock{ L.bbLabel = Nothing } : _ ) -> fail $ unwords ["entry block has no label"]+    ( L.BasicBlock{ L.bbLabel = Just entry_lab } : _ ) -> do+      let (L.Symbol nm) = L.defName defn+      callPushFrame $ Text.pack nm+      setLocation $ Map.toList (L.defMetadata defn)++      bim <- buildBlockInfoMap defn+      blockInfoMap .= bim++      im <- use identMap+      im' <- buildRegMap im defn+      identMap .= im'++      case Map.lookup entry_lab bim of+        Nothing -> fail $ unwords ["entry label not found in label map:", show entry_lab]+        Just entry_bi -> do+          checkEntryPointUseSet nm entry_bi (L.defArgs defn)+          mapM_ (\bb -> defineLLVMBlock retType bim bb) (L.defBody defn)+          jump (block_label entry_bi)+++-- | Check that the input LLVM CFG satisfies the def/use invariant,+--   and raise an error if some virtual register has a use site that+--   is not dominated by its definition site.+checkEntryPointUseSet ::+  String ->+  LLVMBlockInfo s ->+  [L.Typed L.Ident] ->+  LLVMGenerator s arg ret ()+checkEntryPointUseSet nm bi args+  | Set.null unsatisfiedUses = return ()+  | otherwise =+      malformedLLVMModule ("Invalid SSA form for function: " <> pretty nm)+        ([ "The following LLVM virtual registers have at least one use site that"+         , "is not dominated by the corresponding definition:" ] +++         [ "   " <> pretty (show (LPP.ppIdent i)) | i <- Set.toList unsatisfiedUses ])+  where+    argSet = Set.fromList (map L.typedValue args)+    useSet = block_use_set bi+    unsatisfiedUses = Set.difference useSet argSet++------------------------------------------------------------------------+-- transDefine+--+-- | Translate a single LLVM function definition into a crucible CFG.+--+transDefine :: forall arch wptr args ret.+  (HasPtrWidth wptr, wptr ~ ArchWidth arch, ?transOpts :: TranslationOptions) =>+  FnHandle args ret ->+  LLVMContext arch ->+  IORef [LLVMTranslationWarning] ->+  L.Define ->+  IO (L.Declare, C.AnyCFG LLVM)+transDefine h ctx warnRef d = do+  let ?lc = ctx^.llvmTypeCtx+  let decl = declareFromDefine d+  let L.Symbol fstr = L.defName d++  llvmDeclToFunHandleRepr' decl $ \argTys retTy ->+    case (testEquality argTys (handleArgTypes h),+          testEquality retTy (handleReturnType h)) of+       (Nothing, _) -> fail $ unlines+                         [ "Argument type mismatch when defining function: " ++ fstr+                         , show argTys+                         , show h ]+       (_, Nothing) -> fail $ unlines $+                         [ "Return type mismatch when bootstrapping function: " ++ fstr+                         , show retTy, show h+                         ]+       (Just Refl, Just Refl) ->+         do let def :: FunctionDef LLVM (LLVMState arch) args ret IO+                def inputs = (s, f)+                    where s = initialState d ctx argTys inputs warnRef+                          f = genDefn d retTy+            sng <- newIONonceGenerator+            (SomeCFG g, []) <- defineFunctionOpt InternalPos sng h def $ \ng cfg ->+              if optLoopMerge ?transOpts then earlyMergeLoops ng cfg else return cfg+            case toSSA g of+              C.SomeCFG g_ssa -> g_ssa `seq` return (decl, C.AnyCFG g_ssa)+++------------------------------------------------------------------------+-- translateModule++-- | Translate a module into Crucible control-flow graphs.+-- Return the translated module and a list of warning messages+-- generated during translation.+-- Note: We may want to add a map from symbols to existing function handles+-- if we want to support dynamic loading.+translateModule :: (?transOpts :: TranslationOptions)+                => HandleAllocator -- ^ Generator for nonces.+                -> GlobalVar Mem   -- ^ Memory model to associate with this context+                -> L.Module        -- ^ Module to translate+                -> IO (Some ModuleTranslation)+translateModule halloc mvar m = do+  Some ctx <- mkLLVMContext mvar m+  let nonceGen = haCounter halloc+  llvmPtrWidth ctx $ \wptr -> withPtrWidth wptr $+    do let ?lc  = ctx^.llvmTypeCtx -- implicitly passed to makeGlobalMap+       let ctx' = ctx{ llvmGlobalAliases = globalAliases m+                     , llvmFunctionAliases = functionAliases m+                     }+       nonce <- freshNonce nonceGen+       prep <- mapM (prepareCFGMapEntry halloc) (L.modDefines m)+       cfgRef <- newIORef $! Map.fromList [ (L.defName def, UntranslatedCFG def h) | (def,_,h) <- prep ]+       return (Some (ModuleTranslation { _cfgMap = cfgRef+                                       , _globalInitMap = makeGlobalMap ctx' m+                                       , _transContext = ctx'+                                       , _modTransNonce = nonce+                                       , _modTransDefs = [ (decl,h) | (_,decl,h) <- prep ]+                                       , _modTransHalloc = halloc+                                       , _modTransModule = m+                                       , _modTransOpts = ?transOpts+                                       }))++prepareCFGMapEntry ::+  (HasPtrWidth wptr, ?lc :: TypeContext) =>+  HandleAllocator ->+  L.Define ->+  IO (L.Define, L.Declare, SomeHandle)+prepareCFGMapEntry halloc def =+  let decl = declareFromDefine def in+  let L.Symbol fstr = L.defName def in+  let fn_name = functionNameFromText $ Text.pack fstr in+  llvmDeclToFunHandleRepr' decl $ \argTys retTy ->+    do h <- mkHandle' halloc fn_name argTys retTy+       return (def, decl, SomeHandle h)+++-- | Given a 'ModuleTranslation' and a function symbol corresponding to a function+--   defined in the module, attempt to look up the symbol name and retrieve the corresponding+--   Crucible CFG. This will load and translate the CFG if this is the first time+--   the given symbol is requested.+--+--   Will return 'Nothing' if the symbol does not refer to a function defined in this+--   module.+getTranslatedCFG ::+  ModuleTranslation arch ->+  L.Symbol ->+  IO (Maybe (L.Declare, C.AnyCFG LLVM, [LLVMTranslationWarning]))+getTranslatedCFG mt s =+  do m <- readIORef (_cfgMap mt)+     case Map.lookup s m of+       Nothing -> return Nothing+       Just (TranslatedCFG decl cfg) -> return (Just (decl, cfg, []))+       Just (UntranslatedCFG def (SomeHandle h)) ->+         let ?transOpts = _modTransOpts mt in+         let ctx = _transContext mt in+         llvmPtrWidth ctx $ \wptr -> withPtrWidth wptr $+         do warnRef <- newIORef []+            (decl, cfg) <- transDefine h ctx warnRef def+            warns <- reverse <$> readIORef warnRef+            modifyIORef (_cfgMap mt) (Map.insert s (TranslatedCFG decl cfg))+            return (Just (decl, cfg, warns))++-- | Look up the signature and function handle for a function defined in this+--   module translation.  This does not trigger translation of the named function+--   into Crucible if it has not already been requested.+--+--   Will return 'Nothing' if the symbol does not refer to a function defined in this+--   module.+getTranslatedFnHandle ::+  ModuleTranslation arch ->+  L.Symbol ->+  IO (Maybe (L.Declare, SomeHandle))+getTranslatedFnHandle mt s =+  do m <- readIORef (_cfgMap mt)+     case Map.lookup s m of+       Nothing -> return Nothing+       Just (TranslatedCFG decl (C.AnyCFG cfg)) -> return (Just (decl, SomeHandle (C.cfgHandle cfg)))+       Just (UntranslatedCFG def h) -> return (Just (declareFromDefine def, h))
+ src/Lang/Crucible/LLVM/Translation/Aliases.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Aliases+-- Description      : Resolution of global and function aliases+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+-----------------------------------------------------------------------+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE TypeFamilies #-}++module Lang.Crucible.LLVM.Translation.Aliases+ ( globalAliases+ , functionAliases+ , reverseAliases+ ) where++import           Control.Monad+import           Control.Monad.Trans.State++import qualified Data.List as List+import           Data.Maybe+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Sequence (Seq)+import qualified Data.Sequence as Seq++import qualified Text.LLVM.AST as L++import           Lang.Crucible.Panic (panic)+import           Lang.Crucible.LLVM.Types+import           Lang.Crucible.LLVM.TypeContext (TypeContext)+import           Lang.Crucible.LLVM.Translation.Constant++-- | Reverse a set of alias/aliasee relationships+--+-- Given a list of values @l : List A@ and a function @aliasOf : A -> A@,+-- compute a map @Map A (Set A)@ which records the set of things that are+-- transitive aliases of a given @a : A@.+--+-- The keys in the resulting map should be only terminals, e.g. those @a@+-- which aren't aliases of another @a'@ in @l@.+--+-- Requires that the elements of the input sequence are unique.+--+-- Outline:+-- * Initialize the empty map @M : Map A (Set A)@+-- * Initialize an auxilary map @N : Map A A@ which records the final aliasee+--   of each key (the last one in the chain of aliases).+-- * For each @a : A@ in l,+--   1. If @aliasOf a@ is in @N@ as @aliasee@,+--       a. insert @aliasee@ at key @a@ in @N@ (memoize the result)+--       b. insert @a@ into the set at key @aliasee@ in @M@ (record the result)+--       c. recurse on @s@ minus @aliasee@ and @a@.+--   2. If @aliasOf a@ is in @s@, recurse on @l ++ [a]@+--   3. Otherwise,+--       a. insert @a@ at key @a@ in @N@ (memoize the result)+--       b. return the map as-is+--+-- For the sake of practical concerns, the implementation uses \"labels\" for+-- comparison and @aliasOf@, and uses sequences rather than lists.+reverseAliases :: (Ord a, Ord l, Show a, Show l)+               => (a -> l)         -- ^ \"Label of\"+               -> (a -> Maybe l)   -- ^ \"Alias of\"+               -> Seq a+               -> Map a (Set a)+reverseAliases lab aliasOf_ seq_ =+   evalState (go Map.empty seq_) (Map.empty :: Map l a)++  where go map_ Seq.Empty      = pure map_+        go map_ (a Seq.:<| as) =+          case aliasOf_ a of+            Nothing ->+              do -- Don't overwrite it if it's already in the map+                 modify (Map.insert (lab a) a)+                 go (Map.insertWith (\_ old -> old) a Set.empty map_) as+            Just l ->+              do when (lab a == l) $+                   panic "reverseAliases" [ "Self-alias:", show a ]+                 st <- get+                 case Map.lookup l st of+                   Just aliasee ->+                     modify (Map.insert (lab a) aliasee) >>                        -- 1a+                     go (mapSetInsert aliasee a map_)                              -- 1b+                        (Seq.filter (\b -> lab b /= lab aliasee && lab b /= l) as) -- 1c+                   Nothing      ->+                     if isJust (List.find ((l ==) . lab) as)+                     then go map_ (as <> Seq.singleton a)                          -- 2+                     else modify (Map.insert (lab a) a) >>                         -- 3a+                          go map_ as                                               -- 3b+                 where mapSetInsert k v m  = Map.update (pure . Set.insert v) k m++-- | This is one step closer to the application of 'reverseAliases':+-- There are two \"sorts\" of objects:+-- Objects in sort @a@ are never aliases (think global variables).+-- Objects in sort @b@ are usually aliases, to things of either sort+-- (think aliases to global variables).+reverseAliasesTwoSorted :: (Ord a, Ord b, Ord l, Show a, Show b, Show l)+                        => (a -> l)       -- ^ \"Label of\" for type @a@+                        -> (b -> l)       -- ^ \"Label of\" for type @b@+                        -> (b -> Maybe l) -- ^ \"Alias of\"+                        -> Seq a+                        -> Seq b+                        -> Map a (Set b)+reverseAliasesTwoSorted laba labb aliasOf_ seqa seqb =+  Map.fromList . mapMaybe go . Map.toList $+    reverseAliases (either laba labb)+                   (either (const Nothing) aliasOf_)+                   (fmap Left seqa <> fmap Right seqb)+  where -- Drop the b's which have been added as keys and+        go (Right _, _) = Nothing+        -- Call "error" if an a has been tagged as an alias+        go (Left k, s) = Just (k, Set.map errLeft s)+        -- TODO: Should this throw an exception?+        errLeft (Left _)  = error "Internal error: unexpected Left value"+        errLeft (Right v) = v++-- | What does this alias point to?+aliasOf :: (?lc :: TypeContext, HasPtrWidth wptr)+        => L.GlobalAlias+        -> Maybe L.Symbol+aliasOf alias =+  case L.aliasTarget alias of+    L.ValSymbol    symb      -> Just symb+    L.ValConstExpr constExpr ->+      case transConstantExpr constExpr of+        Right (SymbolConst symb 0) -> Just symb+        _ -> Nothing+    -- All other things silently get dropped; it's invalid LLVM code to not have+    -- a symbol or constexpr.+    _ -> Nothing++-- | Get all the aliases that alias (transitively) to a certain global.+globalAliases :: (?lc :: TypeContext, HasPtrWidth wptr)+              => L.Module+              -> Map L.Symbol (Set L.GlobalAlias)+globalAliases mod_ = Map.mapKeys L.globalSym $+  reverseAliasesTwoSorted L.globalSym L.aliasName aliasOf+    (Seq.fromList (L.modGlobals mod_)) (Seq.fromList (L.modAliases mod_))++-- | Get all the aliases that alias (transitively) to a certain function.+functionAliases :: (?lc :: TypeContext, HasPtrWidth wptr)+                => L.Module+                -> Map L.Symbol (Set L.GlobalAlias)+functionAliases mod_ = Map.mapKeys L.defName $+  reverseAliasesTwoSorted L.defName L.aliasName aliasOf+    (Seq.fromList (L.modDefines mod_)) (Seq.fromList (L.modAliases mod_))
+ src/Lang/Crucible/LLVM/Translation/BlockInfo.hs view
@@ -0,0 +1,321 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.BlockInfo+-- Description      : Pre-translation analysis results+-- Copyright        : (c) Galois, Inc 2018-2021+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+-----------------------------------------------------------------------+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Lang.Crucible.LLVM.Translation.BlockInfo+  ( LLVMBlockInfoMap+  , LLVMBlockInfo(..)+  , buildBlockInfoMap+  , useTypedVal+  ) where++import Data.Foldable (toList)+import Data.List (foldl')+import Data.Maybe+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set++import qualified Text.LLVM.AST as L++import           Lang.Crucible.CFG.Generator+import           Lang.Crucible.Panic ( panic )++type LLVMBlockInfoMap s = Map L.BlockLabel (LLVMBlockInfo s)++-- | Information about an LLVM basic block computed before we begin the+--   translation proper.+data LLVMBlockInfo s+  = LLVMBlockInfo+    {+      -- | The crucible block label corresponding to this LLVM block+      block_label :: Label s++      -- | The computed \"use\" set for this block.  This is the set+      -- of identifiers that must be assigned prior to jumping to this+      -- block. They are either used directly in this block or used+      -- by a successor of this block.+      --+      -- Note! \"metadata\" nodes do not contribute to the use set.+      -- This is because LLVM itself relaxes the usual use/def rules+      -- for metadata to prevent debugging information from inhibiting+      -- optimizations.  CF https://bugs.llvm.org/show_bug.cgi?id=51155+      --+      -- Note! values referenced in phi nodes are also not included in+      -- this set, they are instead handled when examining the+      -- terminal statements of predecessor blocks.+    , block_use_set :: !(Set L.Ident)++      -- | The predecessor blocks to this block (i.e., all those blocks+      -- that can jump to this one).+    , block_pred_set :: !(Set L.BlockLabel)++      -- | The successor blocks to this block (i.e., all those blocks+      -- that this block can jump to).+    , block_succ_set :: !(Set L.BlockLabel)++      -- | The statements defining this block+    , block_body :: ![L.Stmt]++      -- | Map from labels to assignments that must be made before+      -- jumping.  If this is the block info for label l',+      -- and the map has [(i1,v1),(i2,v2)] in the phi_map for block l,+      -- then basic block l is required to assign i1 = v1 and i2 = v2+      -- before jumping to block l'.+    , block_phi_map :: !(Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value)))+    }++-- | Construct the block info map for the given function definition.  This collects+--   information about phi-nodes, assigns crucible labels to each basic block, and+--   computes use sets for each block.+buildBlockInfoMap :: Monad m => L.Define -> Generator l s st ret m (LLVMBlockInfoMap s)+buildBlockInfoMap d =+  do bim0 <- Map.fromList <$> (mapM buildBlockInfo $ L.defBody d)+     let bim1 = updatePredSets bim0+     return (computeUseSets bim1)++-- | Build the initial pass of block information. This does not yet compute predecessor+--   sets or use sets.+buildBlockInfo :: Monad m => L.BasicBlock -> Generator l s st ret m (L.BlockLabel, LLVMBlockInfo s)+buildBlockInfo bb = do+  let phi_map = buildPhiMap (L.bbStmts bb)+  let succ_set = buildSuccSet (L.bbStmts bb)+  let blk_lbl = case L.bbLabel bb of+                  Just l -> l+                  Nothing -> panic "crucible-llvm:Translation.buildBlockInfo"+                             [ "unable to obtain label from BasicBlock" ]+  lab <- newLabel+  return (blk_lbl, LLVMBlockInfo{ block_phi_map = phi_map+                                , block_use_set = mempty+                                , block_pred_set = mempty+                                , block_succ_set = succ_set+                                , block_body = L.bbStmts bb+                                , block_label = lab+                                })++-- | Given the statements in a basic block, find all the successor blocks,+-- i.e. the blocks this one may jump to.+buildSuccSet :: [L.Stmt] -> Set L.BlockLabel+buildSuccSet [] = mempty+buildSuccSet (s:ss) =+  case L.stmtInstr s of+    L.Ret{} -> mempty+    L.RetVoid -> mempty+    L.Unreachable -> mempty+    L.Jump l -> Set.singleton l+    L.Br _ l1 l2 -> Set.fromList [l1,l2]+    L.CallBr _ _ _ norm other -> Set.fromList (norm:other)+    L.Invoke _ _ _ l1 l2 -> Set.fromList [l1,l2]+    L.IndirectBr _ ls -> Set.fromList ls+    L.Switch _ ldef ls -> Set.fromList (ldef:map snd ls)+    _ -> buildSuccSet ss+++-- | Compute predecessor sets from the successor sets already computed in @buildBlockInfo@+updatePredSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s+updatePredSets bim0 = foldl' upd bim0 predEdges+  where+   upd bim (to,from) = Map.adjust (\bi -> bi{ block_pred_set = Set.insert from (block_pred_set bi) }) to bim++   predEdges =+     [ (to,from) | (from, bi) <- Map.assocs bim0+                 , to <- Set.elems (block_succ_set bi)+     ]++-- | Compute use sets for each basic block. These sets list all the+-- virtual registers that must be assigned before jumping to a+-- block.+--+-- This is essentially a backward fixpoint computation based on the+-- identifiers used in the block statements.  We iterate the use/def+-- transfer function until no more changes are made.  Because it is a+-- backward analysis, we (heuristically) examine the blocks in+-- descending order, and re-add blocks to the workset based on+-- predecessor maps.+--+-- This fixpoint computation terminates for the usual reasons: the transfer+-- function is monotonic (use sets only increase) and has no infinite+-- chains (in the worst case, all the finitely-many identifiers in the+-- function end up in every use set).+computeUseSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s+computeUseSets bim0 = loop bim0 (Map.keysSet bim0) -- start with all blocks in the workset+  where+  loop bim ws =+    -- choose the largest remaining block label in the workset+    case Set.maxView ws of+      -- if the workset is empty, we are done+      Nothing -> bim+      Just (l, ws') ->+        -- look up the current block information relating to block l+        case Map.lookup l bim of+          Nothing -> panic "computeUseSets" ["Could not find label", show l]+          Just bi ->+            -- run the transfer function and compute an updated use set+            case updateUseSet l bi bim of+              -- if there is no update, continue down the work set+              Nothing -> loop bim ws'+              -- if we updated the use set, record it in the block map and+              -- add all the predecessors of this block back to the work set+              Just bi' ->+                loop (Map.insert l bi' bim) (Set.union ws' (block_pred_set bi'))++-- | Run the use/def transfer function on the block body and update the block info if+-- any changes are detected+updateUseSet :: L.BlockLabel -> LLVMBlockInfo s -> Map L.BlockLabel (LLVMBlockInfo s) -> Maybe (LLVMBlockInfo s)+updateUseSet lab bi bim = if newuse == block_use_set bi then Nothing else Just bi{ block_use_set = newuse }+  where+  newuse = loop (block_body bi)++  loop [] = mempty++  -- invoke and callbr are a special case when their return values are assigned+  -- to registers: the return values can only be used in the "normal" successor+  -- block.++  loop (L.Result nm i _md:ss) =+    case i of+      L.Invoke _tp f args l_normal l_unwind ->+            -- the use sets from the function value, arguments, and unwind label+        let uss = [useVal f, useLabel lab l_unwind bim] ++ map useTypedVal args+            -- the use set from the normal return label, note that nm is in scope here+            u_normal = Set.delete nm (useLabel lab l_normal bim)+            -- invoke is a block terminator, we can ignore the tail of the list+         in Set.unions (u_normal : uss)++      L.CallBr _tp f args l_normal ls ->+            -- the use sets from the function value, arguments, and non-normal+            -- labels+        let uss = useVal f:(map (\l -> useLabel lab l bim) ls ++ map useTypedVal args)+            -- the use set from the normal return label, note that nm is in scope here+            u_normal = Set.delete nm (useLabel lab l_normal bim)+            -- callbr is a block terminator, we can ignore the tail of the list+         in Set.unions (u_normal : uss)++      -- In other cases, combine the use set of the instruction with+      -- the use set of following instructions, after deleting the register+      -- defined here+      _ -> Set.union (instrUse lab i bim) (Set.delete nm (loop ss))++  loop (L.Effect i _md:ss) = Set.union (instrUse lab i bim) (loop ss)++instrUse :: L.BlockLabel -> L.Instr -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident+instrUse from i bim = Set.unions $ case i of+  L.Phi{} -> [] -- NB, phi node use is handled in `useLabel`+  L.RetVoid -> []+  L.Ret tv -> [useTypedVal tv]+  L.Arith _op x y -> [useTypedVal x, useVal y]+  L.Bit _op x y -> [useTypedVal x, useVal y ]+  L.Conv _op x _tp -> [useTypedVal x]+  L.Call _tailCall _tp f args -> useVal f : map useTypedVal args+  -- NB, this is only correct for "callbr" instructions that don't assign the return value+  L.CallBr _tp f args norm ls ->+    [useVal f, useLabel from norm bim] +++      map (\l -> useLabel from l bim) ls +++      map useTypedVal args+  L.Alloca _tp Nothing  _align -> []+  L.Alloca _tp (Just x) _align -> [useTypedVal x]+  L.Load _tp p _ord _align -> [useTypedVal p]+  L.Store p v _ord _align -> [useTypedVal p, useTypedVal v]+  L.Fence{} -> []+  L.CmpXchg _weak _vol p v1 v2 _s _o1 _o2 -> map useTypedVal [p,v1,v2]+  L.AtomicRW _vol _op p v _s _o -> [useTypedVal p, useTypedVal v]+  L.ICmp _op x y -> [useTypedVal x, useVal y]+  L.FCmp _op x y -> [useTypedVal x, useVal y]+  L.GEP _ib _tp base args -> useTypedVal base : map useTypedVal args+  L.Select c x y -> [ useTypedVal c, useTypedVal x, useVal y ]+  L.ExtractValue x _ixs -> [useTypedVal x]+  L.InsertValue x y _ixs -> [useTypedVal x, useTypedVal y]+  L.ExtractElt x y -> [useTypedVal x, useVal y]+  L.InsertElt x y z -> [useTypedVal x, useTypedVal y, useVal z]+  L.ShuffleVector x y z -> [useTypedVal x, useVal y, useTypedVal z]+  L.Jump l -> [useLabel from l bim]+  L.Br c l1 l2 -> [useTypedVal c, useLabel from l1 bim, useLabel from l2 bim]+  -- NB, this is only correct for "invoke" instructions that don't assign the return value+  L.Invoke _tp f args l1 l2 -> [useVal f, useLabel from l1 bim, useLabel from l2 bim] ++ map useTypedVal args+  L.Comment{} -> []+  L.Unreachable -> []+  L.Unwind -> [] -- ??+  L.VaArg x _tp -> [useTypedVal x]+  L.IndirectBr x ls -> useTypedVal x : [ useLabel from l bim | l <- ls ]+  L.Switch c def bs -> useTypedVal c : useLabel from def bim : [ useLabel from l bim | (_,l) <- bs ]+  L.Resume x -> [useTypedVal x]+  L.LandingPad _tp Nothing _ cls -> map useClause cls+  L.LandingPad _tp (Just cleanup) _ cls -> useTypedVal cleanup : map useClause cls+  L.UnaryArith _op x -> [useTypedVal x]+  L.Freeze x -> [useTypedVal x]++useClause :: L.Clause -> Set L.Ident+useClause (L.Catch v) = useTypedVal v+useClause (L.Filter v) = useTypedVal v++useLabel :: L.BlockLabel -> L.BlockLabel -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident+useLabel from to bim =+  case Map.lookup to bim of+    Nothing -> panic "useLabel" ["Could not find label", show to]+    Just bi ->+      let phiList =+            case Map.lookup from (block_phi_map bi) of+              Nothing -> []+              Just ps -> toList ps+      in Set.unions (block_use_set bi : [ useVal v | (_,_,v) <- phiList ])++-- | Compute the set of identifiers referenced by the given typed value+useTypedVal :: L.Typed (L.Value) -> Set L.Ident+useTypedVal tv = useVal (L.typedValue tv)++-- | Compute the set of identifiers referenced by the given value+useVal :: L.Value -> Set L.Ident+useVal v = Set.unions $ case v of+  L.ValInteger{} ->  []+  L.ValBool{} -> []+  L.ValFloat{} -> []+  L.ValDouble{} -> []+  L.ValFP80{} -> []+  L.ValIdent i -> [Set.singleton i]+  L.ValSymbol _s -> []+  L.ValNull -> []+  L.ValArray _tp vs -> map useVal vs+  L.ValVector _tp vs -> map useVal vs+  L.ValStruct vs -> map useTypedVal vs+  L.ValPackedStruct vs -> map useTypedVal vs+  L.ValString _ -> []+  L.ValConstExpr{} -> [] -- TODO? should we look through constant exprs?+  L.ValUndef -> []+  L.ValLabel _ -> []+  L.ValZeroInit -> []+  L.ValAsm{} -> [] -- TODO! inline asm ...+  L.ValPoison{} -> []++  -- NB! metadata values are not considered as part of our use analysis+  L.ValMd _md -> []+++-- | Given the statements in a basic block, find all the phi instructions and+-- compute the list of assignments that must be made for each predecessor block.+buildPhiMap :: [L.Stmt] -> Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value))+buildPhiMap ss = go ss Map.empty+ where go (L.Result ident (L.Phi tp xs) _ : stmts) m = go stmts (go' ident tp xs m)+       go _ m = m++       f x mseq = Just (fromMaybe Seq.empty mseq Seq.|> x)++       go' ident tp ((v, lbl) : xs) m = go' ident tp xs (Map.alter (f (ident,tp,v)) lbl m)+       go' _ _ [] m = m
+ src/Lang/Crucible/LLVM/Translation/Constant.hs view
@@ -0,0 +1,1204 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Constant+-- Description      : LLVM constant expression evaluation and GEPs+-- Copyright        : (c) Galois, Inc 2014-2015+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- This module provides translation-time evaluation of constant+-- expressions.  It also provides an intermediate representation+-- for GEP (getelementpointer) instructions that makes more explicit+-- the places where vectorization may occur, as well as resolving type+-- sizes and field offsets.+--+-- See @liftConstant@ for how to turn these into expressions.+-----------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Lang.Crucible.LLVM.Translation.Constant+  ( -- * Representation of LLVM constant values+    LLVMConst(..)+  , boolConst+  , intConst++    -- * Translations from LLVM syntax to constant values+  , transConstant+  , transConstantWithType+  , transConstant'+  , transConstantExpr++    -- * Intermediate representation for GEP+  , GEP(..)+  , GEPResult(..)+  , translateGEP++    -- * Utility functions+  , showInstr+  , testBreakpointFunction+  ) where++import           Control.Lens( to, (^.) )+import           Control.Monad+import           Control.Monad.Except+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import           Data.Bits+import           Data.Kind+import           Data.List (intercalate, isPrefixOf)+import           Data.Traversable+import           Data.Fixed (mod')+import qualified Data.Vector as V+import           Numeric.Natural+import           GHC.TypeNats++import qualified Text.LLVM.AST as L+import qualified Text.LLVM.PP as L++import qualified Data.BitVector.Sized as BV+import qualified Data.BitVector.Sized.Overflow as BV+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Some+import           Data.Parameterized.DecidableEq (decEq)++import           Lang.Crucible.LLVM.Bytes+import           Lang.Crucible.LLVM.DataLayout( intLayout, EndianForm(..) )+import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemType+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext++-- | Pretty print an LLVM instruction+showInstr :: L.Instr -> String+showInstr i = show (L.ppLLVM38 (L.ppInstr i))++-- | Intermediate representation of a GEP.+--   A @GEP n expr@ is a representation of a GEP with+--   @n@ parallel vector lanes with expressions represented+--   by @expr@ values.+data GEP (n :: Nat) (expr :: Type) where+  -- | Start a GEP with a single base pointer+  GEP_scalar_base  :: expr -> GEP 1 expr++  -- | Start a GEP with a vector of @n@ base pointers+  GEP_vector_base  :: NatRepr n -> expr -> GEP n expr++  -- | Copy a scalar base vector pointwise into a+  --   vector of length @n@.+  GEP_scatter      :: NatRepr n -> GEP 1 expr -> GEP n expr++  -- | Add the offset corresponding to the given field+  --   pointwise to each pointer+  GEP_field        :: FieldInfo -> GEP n expr -> GEP n expr++  -- | Add an offset corresponding to the given array index+  --   (multiplied by the given type size) pointwise to the pointers+  --   in each lane.+  GEP_index_each   :: MemType -> GEP n expr -> expr -> GEP n expr++  -- | Given a vector of offsets (whose length must match+  --   the number of lanes), multiply each one by the+  --   type size, and add the offsets to the corresponding+  --   pointers.+  GEP_index_vector :: MemType -> GEP n expr -> expr -> GEP n expr++instance Functor (GEP n) where+  fmap = fmapDefault+instance Foldable (GEP n) where+  foldMap = foldMapDefault++instance Traversable (GEP n) where+  traverse f gep = case gep of+    GEP_scalar_base x            -> GEP_scalar_base <$> f x+    GEP_vector_base n x          -> GEP_vector_base n <$> f x+    GEP_scatter n gep'           -> GEP_scatter n <$> traverse f gep'+    GEP_field fi gep'            -> GEP_field fi <$> traverse f gep'+    GEP_index_each mt gep' idx   -> GEP_index_each mt <$> traverse f gep' <*> f idx+    GEP_index_vector mt gep' idx -> GEP_index_vector mt <$> traverse f gep' <*> f idx++-- | The result of a GEP instruction translation.  It records the number+--   of parallel vector lanes in the resulting instruction, the resulting+--   memory type of the instruction, and the sequence of sub-operations+--   required to compute the GEP instruction.+data GEPResult expr where+  GEPResult :: (1 <= n) => NatRepr n -> MemType -> GEP n expr -> GEPResult expr++instance Functor GEPResult where+  fmap = fmapDefault+instance Foldable GEPResult where+  foldMap = foldMapDefault++instance Traversable GEPResult where+  traverse f (GEPResult n mt gep) = GEPResult n mt <$> traverse f gep+++-- | Given the data for an LLVM getelementpointer instruction,+-- preprocess the instruction into a @GEPResult@, checking+-- types, computing vectorization lanes, etc.+--+-- As a concrete example, consider a call to+-- @'translateGEP' inbounds baseTy basePtr elts@ with the following+-- instruction:+--+-- @+-- getelementptr [12 x i8], ptr %aptr, i64 0, i32 1+-- @+--+-- Here:+--+-- * @inbounds@ is 'False', as the keyword of the same name is missing from+--   the instruction. (Currently, @crucible-llvm@ ignores this information.)+--+-- * @baseTy@ is @[12 x i8]@. This is the type used as the basis for+--   subsequent calculations.+--+-- * @basePtr@ is @ptr %aptr@. This pointer is used as the base address to+--   start calculations from. Note that the type of @basePtr@ is /not/+--   @baseTy@, but rather a pointer type.+--+-- * The @elts@ are @[i64 0, i32 1]@. These are the indices that indicate+--   which of the elements of the aggregate object are indexed.+translateGEP :: forall wptr m.+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  Bool              {- ^ inbounds flag -} ->+  L.Type            {- ^ base type for calculations -} ->+  L.Typed L.Value   {- ^ base pointer expression -} ->+  [L.Typed L.Value] {- ^ index arguments -} ->+  m (GEPResult (L.Typed L.Value))++translateGEP _ _ _ [] =+  throwError "getelementpointer must have at least one index"++translateGEP inbounds baseTy basePtr elts =+  do baseMemType <- liftMemType baseTy+     mt <- liftMemType (L.typedType basePtr)+     -- Input value to a GEP must have a pointer type (or be a vector of pointer+     -- types), and the base type used for calculations must be representable+     -- as a memory type. The resulting memory type drives the interpretation of+     -- the GEP arguments.+     case mt of+       -- Vector base case, with as many lanes as there are input pointers+       VecType n vmt+         | isPointerMemType vmt+         , Some lanes <- mkNatRepr n+         , Just LeqProof <- isPosNat lanes+         ->  let mt' = ArrayType 0 baseMemType in+             go lanes mt' (GEP_vector_base lanes basePtr) elts++       -- Scalar base case with exactly 1 lane+       _ | isPointerMemType mt+         ->  let mt' = ArrayType 0 baseMemType in+             go (knownNat @1) mt' (GEP_scalar_base basePtr) elts++         | otherwise+         -> badGEP+ where+ badGEP :: m a+ badGEP = throwError $ unlines [ "Invalid GEP", showInstr (L.GEP inbounds baseTy basePtr elts) ]++ -- This auxilary function builds up the intermediate GEP mini-instructions that compute+ -- the overall GEP, as well as the resulting memory type of the final pointers and the+ -- number of vector lanes eventually computed by the GEP.+ go ::+   (1 <= lanes) =>+   NatRepr lanes               {- Number of lanes of the GEP so far -} ->+   MemType                     {- Memory type of the incoming pointer(s) -} ->+   GEP lanes (L.Typed L.Value) {- partial GEP computation -} ->+   [L.Typed L.Value]           {- remaining arguments to process -} ->+   m (GEPResult (L.Typed L.Value))++ -- Final step, all arguments are used up, return the GEPResult+ go lanes mt gep [] = return (GEPResult lanes mt gep)++ -- Resolve one offset value and recurse+ go lanes mt gep (off:xs) =+   do offt <- liftMemType (L.typedType off)+      -- The meaning of the offset depends on the static type of the intermediate result+      case mt of+        ArrayType _ mt' -> goArray lanes off offt mt' gep xs+        VecType   _ mt' -> goArray lanes off offt mt' gep xs+        StructType si   -> goStruct lanes off offt si gep xs+        _ -> badGEP++ -- If it is an array type, the offset should be considered an array index, or+ -- vector of array indices.+ goArray ::+   (1 <= lanes) =>+   NatRepr lanes   {- Number of lanes of the GEP so far -} ->+   L.Typed L.Value {- Current index value -} ->+   MemType         {- MemType of the index value -} ->+   MemType         {- MemType of the incoming pointer(s) -} ->+   GEP lanes (L.Typed L.Value) {- partial GEP computation -} ->+   [L.Typed L.Value] {- remaining arguments to process -} ->+   m (GEPResult (L.Typed L.Value))+ goArray lanes off offt mt' gep xs =+    case offt of+      -- Single array index, apply pointwise to all intermediate pointers+      IntType _+        -> go lanes mt' (GEP_index_each mt' gep off) xs++      -- Vector of indices, matching the current number of lanes, apply+      -- each offset to the corresponding base pointer+      VecType n (IntType _)+        | natValue lanes == n+        -> go lanes mt' (GEP_index_vector mt' gep off) xs++      -- Vector of indices, with a single incoming base pointer.  Scatter+      -- the base pointer across the correct number of lanes, and then+      -- apply the vector of offsets componentwise.+      VecType n (IntType _)+        | Some n' <- mkNatRepr n+        , Just LeqProof <- isPosNat n'+        , Just Refl <- testEquality lanes (knownNat @1)+        -> go n' mt' (GEP_index_vector mt' (GEP_scatter n' gep) off) xs++      -- Otherwise, some sort of mismatch occured.+      _ -> badGEP++ -- If it is a structure type, the index must be a constant value that indicates+ -- which field (counting from 0) is to be indexed.+ goStruct ::+   (1 <= lanes) =>+   NatRepr lanes     {- Number of lanes of the GEP so far -} ->+   L.Typed L.Value   {- Field index number -} ->+   MemType           {- MemType of the field index -} ->+   StructInfo        {- Struct layout information -} ->+   GEP lanes (L.Typed L.Value) {- partial GEP computation -} ->+   [L.Typed L.Value] {- remaining arguments to process -} ->+   m (GEPResult (L.Typed L.Value))+ goStruct lanes off offt si gep xs =+    do off' <- transConstant' offt (L.typedValue off)+       case off' of+         -- Special case for the zero value+         ZeroConst (IntType _) -> goidx 0++         -- Single index; compute the corresponding field.+         IntConst _ idx -> goidx (BV.asUnsigned idx)++         -- Special case.  A vector of indices is allowed, but it must be of the correct+         -- number of lanes, and each (constant) index must be the same value.+         VectorConst (IntType _) (i@(IntConst _ idx) : is) | all (same i) is -> goidx (BV.asUnsigned idx)+           where+           same :: LLVMConst -> LLVMConst -> Bool+           same (IntConst wx x) (IntConst wy y)+             | Just Refl <- testEquality wx wy = x == y+           same _ _ = False++         -- Otherwise, invalid GEP instruction+         _ -> badGEP++            -- using the information from the struct type, figure out which+            -- field is indicated+      where goidx idx | 0 <= idx && idx < toInteger (V.length flds) =+                 go lanes (fiType fi) (GEP_field fi gep) xs+               where flds = siFields si+                     fi   = flds V.! (fromInteger idx)++            goidx _ = badGEP+++-- | Translation-time LLVM constant values.+data LLVMConst where+  -- | A constant value consisting of all zero bits.+  ZeroConst     :: !MemType -> LLVMConst+  -- | A constant integer value, with bit-width @w@.+  IntConst      :: (1 <= w) => !(NatRepr w) -> !(BV.BV w) -> LLVMConst+  -- | A constant floating point value.+  FloatConst    :: !Float -> LLVMConst+  -- | A constant double value.+  DoubleConst   :: !Double -> LLVMConst+  -- | A constant long double value (X86_FP80)+  LongDoubleConst :: !L.FP80Value -> LLVMConst+  -- | A constant sequence of bytes+  StringConst   :: !ByteString -> LLVMConst+  -- | A constant array value.+  ArrayConst    :: !MemType -> [LLVMConst] -> LLVMConst+  -- | A constant vector value.+  VectorConst   :: !MemType -> [LLVMConst] -> LLVMConst+  -- | A constant structure value.+  StructConst   :: !StructInfo -> [LLVMConst] -> LLVMConst+  -- | A pointer value, consisting of a concrete offset from a global symbol.+  SymbolConst   :: !L.Symbol -> !Integer -> LLVMConst+  -- | The @undef@ value is quite strange. See: The LLVM Language Reference,+  -- § Undefined Values.+  UndefConst    :: !MemType -> LLVMConst+++-- | This also can't be derived, but is completely uninteresting.+instance Show LLVMConst where+  show lc = intercalate " " $+    case lc of+      (ZeroConst mem)     -> ["ZeroConst", show mem]+      (IntConst w x)      -> ["IntConst", show w, show x]+      (FloatConst f)      -> ["FloatConst", show f]+      (DoubleConst d)     -> ["DoubleConst", show d]+      ld@(LongDoubleConst _)-> ["LongDoubleConst", show ld]+      (ArrayConst mem a)  -> ["ArrayConst", show mem, show a]+      (VectorConst mem v) -> ["VectorConst", show mem, show v]+      (StructConst si a)  -> ["StructConst", show si, show a]+      (SymbolConst s x)   -> ["SymbolConst", show s, show x]+      (UndefConst mem)    -> ["UndefConst", show mem]+      (StringConst bs)    -> ["StringConst", show bs]++-- | The interesting cases here are:+--  * @IntConst@: GHC can't derive this because @IntConst@ existentially+--    quantifies the integer's width. We say that two integers are equal when+--    they have the same width *and* the same value.+--  * @UndefConst@: Two @undef@ values aren't necessarily the same...+instance Eq LLVMConst where+  (ZeroConst mem1)      == (ZeroConst mem2)      = mem1 == mem2+  (IntConst w1 x1)      == (IntConst w2 x2)      =+    case decEq w1 w2 of+      Left Refl -> x1 == x2+      Right _   -> False+  (FloatConst f1)       == (FloatConst f2)       = f1 == f2+  (DoubleConst d1)      == (DoubleConst d2)      = d1 == d2+  (LongDoubleConst ld1) == (LongDoubleConst ld2) = ld1 == ld2+  (ArrayConst mem1 a1)  == (ArrayConst mem2 a2)  = mem1 == mem2 && a1 == a2+  (VectorConst mem1 v1) == (VectorConst mem2 v2) = mem1 == mem2 && v1 == v2+  (StructConst si1 a1)  == (StructConst si2 a2)  = si1 == si2   && a1 == a2+  (SymbolConst s1 x1)   == (SymbolConst s2 x2)   = s1 == s2     && x1 == x2+  (UndefConst  _)       == (UndefConst _)        = False+  _                     == _                     = False++-- | Create an LLVM constant value from a boolean.+boolConst :: Bool -> LLVMConst+boolConst False = IntConst (knownNat @1) (BV.zero knownNat)+boolConst True = IntConst (knownNat @1) (BV.one knownNat)++-- | Create an LLVM constant of a given width.  The resulting integer+--   constant value will be the unsigned integer value @n mod 2^w@.+intConst ::+  MonadError String m =>+  Natural {- ^ width of the integer constant, @w@ -} ->+  Integer {- ^ value of the integer constant, @n@ -} ->+  m LLVMConst+intConst n 0+  = return (ZeroConst (IntType n))+intConst n x+  | Some w <- mkNatRepr n+  , Just LeqProof <- isPosNat w+  = return (IntConst w (BV.mkBV w x))+intConst n _+  = throwError ("Invalid integer width: " ++ show n)++-- | Compute the constant value of an expression.  Fail if the+--   given value does not represent a constant.+transConstantWithType ::+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  L.Typed L.Value ->+  m (MemType, LLVMConst)+transConstantWithType (L.Typed tp v) =+  do mt <- liftMemType tp+     c <- transConstant' mt v+     return (mt, c)++transConstant ::+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  L.Typed L.Value ->+  m LLVMConst+transConstant x = snd <$> transConstantWithType x++-- | Compute the constant value of an expression.  Fail if the+--   given value does not represent a constant.+transConstant' ::+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  MemType ->+  L.Value ->+  m LLVMConst+transConstant' tp (L.ValUndef) =+  return (UndefConst tp)+transConstant' (IntType n) (L.ValInteger x) =+  intConst n x+transConstant' (IntType 1) (L.ValBool b) =+  return . IntConst (knownNat @1) $ if b+                                    then (BV.one knownNat)+                                    else (BV.zero knownNat)+transConstant' FloatType (L.ValFloat f) =+  return (FloatConst f)+transConstant' DoubleType (L.ValDouble d) =+  return (DoubleConst d)+transConstant' X86_FP80Type (L.ValFP80 ld) =+  return (LongDoubleConst ld)+transConstant' (PtrType _) (L.ValSymbol s) =+  return (SymbolConst s 0)+transConstant' PtrOpaqueType (L.ValSymbol s) =+  return (SymbolConst s 0)+transConstant' tp L.ValZeroInit =+  return (ZeroConst tp)+transConstant' (PtrType stp) L.ValNull =+  return (ZeroConst (PtrType stp))+transConstant' PtrOpaqueType L.ValNull =+  return (ZeroConst PtrOpaqueType)+transConstant' (VecType n tp) (L.ValVector _tp xs)+  | n == fromIntegral (length xs)+  = VectorConst tp <$> traverse (transConstant' tp) xs+transConstant' (ArrayType n tp) (L.ValArray _tp xs)+  | n == fromIntegral (length xs)+  = ArrayConst tp <$> traverse (transConstant' tp) xs+transConstant' (StructType si) (L.ValStruct xs)+  | not (siIsPacked si)+  , V.length (siFields si) == length xs+  = StructConst si <$> traverse transConstant xs+transConstant' (StructType si) (L.ValPackedStruct xs)+  | siIsPacked si+  , V.length (siFields si) == length xs+  = StructConst si <$> traverse transConstant xs++transConstant' (ArrayType n tp) (L.ValString cs)+  | tp == IntType 8, n == fromIntegral (length cs)+  = return . StringConst $! BS.pack cs++transConstant' _ (L.ValConstExpr cexpr) = transConstantExpr cexpr++transConstant' tp val =+  throwError $ unlines [ "Cannot compute constant value for expression: "+                       , "Type: "  ++ (show $ ppMemType tp)+                       , "Value: " ++ (show $ LPP.ppValue val)+                       ]+++-- | Evaluate a GEP instruction to a constant value.+evalConstGEP :: forall m wptr.+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  GEPResult LLVMConst ->+  m (MemType, LLVMConst)+evalConstGEP (GEPResult lanes finalMemType gep0) =+   do xs <- go gep0+      unless (fromIntegral (length xs) == natValue lanes)+             (throwError "Unexpected vector length in result of constant GEP")+      case xs of+        [x] -> return ( PtrType (MemType finalMemType), x)+        _   -> return ( VecType (fromIntegral (length xs)) (PtrType (MemType finalMemType))+                      , VectorConst (PtrType (MemType finalMemType)) xs+                      )++  where+  dl = llvmDataLayout ?lc++  asOffset :: MemType -> LLVMConst -> m Integer+  asOffset _ (ZeroConst (IntType _)) = return 0+  asOffset mt (IntConst _ x) =+    do let x' = BV.asUnsigned x * bytesToInteger (memTypeSize dl mt)+       unless (x' <= maxUnsigned ?ptrWidth)+              (throwError "Computed offset overflow in constant GEP")+       return x'+  asOffset ty val = throwError $ unlines $+    [ "Expected offset value in constant GEP"+    , "Type: " ++ show ty+    , "Offset: " ++ show val+    ]++  addOffset :: Integer -> LLVMConst -> m LLVMConst+  addOffset x (SymbolConst sym off) = return (SymbolConst sym (off+x))+  addOffset _ constant = throwError $ unlines $+    [ "Expected symbol constant in constant GEP"+    , "Constant: " ++ show constant+    ]++  -- Given a processed GEP instruction, compute the sequence of output+  -- pointer values that result from the instruction.  If the GEP is+  -- scalar-valued, then the result will be a list of one element.+  go :: GEP n LLVMConst -> m [LLVMConst]++  -- Scalar base, return a list containing just the base value.+  go (GEP_scalar_base base)+    = return [base]++  -- Vector base, deconstruct the input value and return the+  -- corresponding values.+  go (GEP_vector_base n x)+    = asVectorOf (natValue n) return x++  -- Scatter a scalar input across n lanes+  go (GEP_scatter n gep)+    = do ps <- go gep+         case ps of+           [p] -> return (replicate (widthVal n) p)+           _   -> throwError "vector length mismatch in GEP scatter"++  -- Add the offset corresponding to the given field across+  -- all the lanes of the GEP+  go (GEP_field fi gep)+    = do ps <- go gep+         let i = bytesToInteger (fiOffset fi)+         traverse (addOffset i) ps++  -- Compute the offset corresponding to the given array index+  -- and add that offest across all the lanes of the GEP+  go (GEP_index_each mt gep x)+    = do ps <- go gep+         i  <- asOffset mt x+         traverse (addOffset i) ps++  -- For each index in the input vector, compute and offset according+  -- to the given memory type and add the corresponding offset across+  -- each lane of the GEP componentwise.+  go (GEP_index_vector mt gep x)+    = do ps <- go gep+         is <- asVectorOf (fromIntegral (length ps)) (asOffset mt) x+         zipWithM addOffset is ps++-- | Evaluate a floating point comparison.+evalFcmp ::+  RealFloat a =>+  L.FCmpOp ->+  a -> a -> LLVMConst+evalFcmp op x y = boolConst $ case op of+  L.Ffalse -> False+  L.Ftrue  -> True+  L.Foeq   -> ordered && x == y+  L.Fone   -> ordered && x /= y+  L.Fogt   -> ordered && x >  y+  L.Foge   -> ordered && x >= y+  L.Folt   -> ordered && x <  y+  L.Fole   -> ordered && x <= y+  L.Ford   -> ordered+  L.Fueq   -> unordered || x == y+  L.Fune   -> unordered || x /= y+  L.Fugt   -> unordered || x >  y+  L.Fuge   -> unordered || x >= y+  L.Fult   -> unordered || x <  y+  L.Fule   -> unordered || x <= y+  L.Funo   -> unordered+ where+ unordered = isNaN x || isNaN y+ ordered   = not unordered++-- | Evaluate an integer comparison.+evalIcmp ::+  (1 <= w) =>+  L.ICmpOp ->+  NatRepr w ->+  BV.BV w -> BV.BV w -> LLVMConst+evalIcmp op w x y = boolConst $ case op of+  L.Ieq  -> x == y+  L.Ine  -> x /= y+  L.Iugt -> BV.ult y x+  L.Iuge -> BV.ule y x+  L.Iult -> BV.ult x y+  L.Iule -> BV.ule x y+  L.Isgt -> BV.slt w y x+  L.Isge -> BV.sle w y x+  L.Islt -> BV.slt w x y+  L.Isle -> BV.sle w x y++-- | Evaluate a binary arithmetic operation.+evalArith ::+  (MonadError String m, HasPtrWidth wptr) =>+  L.ArithOp ->+  MemType ->+  Arith -> Arith -> m LLVMConst+evalArith op (IntType m) (ArithI x) (ArithI y)+  | Just (Some w) <- someNat m+  , Just LeqProof <- isPosNat w+  = evalIarith op w x y+evalArith op FloatType (ArithF x) (ArithF y) = FloatConst <$> evalFarith op x y+evalArith op DoubleType (ArithD x) (ArithD y) = DoubleConst <$> evalFarith op x y+evalArith _ _ _ _ = throwError "binary arithmetic argument mismatch"++-- | Evaluate a unary arithmetic operation.+evalUnaryArith ::+  (MonadError String m, HasPtrWidth wptr) =>+  L.UnaryArithOp ->+  MemType ->+  Arith -> m LLVMConst+evalUnaryArith op FloatType (ArithF x) = FloatConst <$> evalFunaryArith op x+evalUnaryArith op DoubleType (ArithD x) = DoubleConst <$> evalFunaryArith op x+evalUnaryArith _ _ _ = throwError "unary arithmetic argument mismatch"++-- | Evaluate a binary floating-point operation.+evalFarith ::+  (RealFrac a, MonadError String m) =>+  L.ArithOp ->+  a -> a -> m a+evalFarith op x y =+  case op of+    L.FAdd -> return (x + y)+    L.FSub -> return (x - y)+    L.FMul -> return (x * y)+    L.FDiv -> return (x / y)+    L.FRem -> return (mod' x y)+    _ -> throwError "Encountered integer arithmetic operation applied to floating point arguments"++-- | Evaluate a unary floating-point operation.+evalFunaryArith ::+  (RealFrac a, MonadError String m) =>+  L.UnaryArithOp ->+  a -> m a+evalFunaryArith op x =+  case op of+    L.FNeg -> return (negate x)++-- | Evaluate an integer or pointer arithmetic operation.+evalIarith ::+  (1 <= w, MonadError String m, HasPtrWidth wptr) =>+  L.ArithOp ->+  NatRepr w ->+  ArithInt -> ArithInt -> m LLVMConst+evalIarith op w (ArithInt x) (ArithInt y)+  = IntConst w <$> evalIarith' op w (BV.mkBV w x) (BV.mkBV w y)+evalIarith op w (ArithPtr sym x) (ArithInt y)+  | Just Refl <- testEquality w ?ptrWidth+  , L.Add _ _ <- op+  = return $ SymbolConst sym (x+y)+  | otherwise+  = throwError "Illegal operation applied to pointer argument"+evalIarith op w (ArithInt x) (ArithPtr sym y)+  | Just Refl <- testEquality w ?ptrWidth+  , L.Add _ _ <- op+  = return $ SymbolConst sym (x+y)+  | otherwise+  = throwError "Illegal operation applied to pointer argument"+evalIarith op w (ArithPtr symx x) (ArithPtr symy y)+  | Just Refl <- testEquality w ?ptrWidth+  , symx == symy+  , L.Sub _ _ <- op+  = return $ IntConst ?ptrWidth (BV.mkBV ?ptrWidth (x - y))+  | otherwise+  = throwError "Illegal operation applied to pointer argument"++-- | Evaluate an integer (non-pointer) arithmetic operation.+evalIarith' ::+  (1 <= w, MonadError String m) =>+  L.ArithOp ->+  NatRepr w ->+  BV.BV w -> BV.BV w -> m (BV.BV w)+evalIarith' op w x y = do+  let nuwTest nuw zres =+        when (nuw && BV.ofUnsigned zres)+             (throwError "Unsigned overflow in constant arithmetic operation")+  let nswTest nsw zres =+        when (nsw && BV.ofSigned zres)+             (throwError "Signed overflow in constant arithmetic operation")+  case op of+    L.Add nuw nsw ->+      do let zres = BV.addOf w x y+         nuwTest nuw zres+         nswTest nsw zres+         return (BV.ofResult zres)++    L.Sub nuw nsw ->+      do let zres = BV.subOf w x y+         nuwTest nuw zres+         nswTest nsw zres+         return (BV.ofResult zres)++    L.Mul nuw nsw ->+      do let zres = BV.mulOf w x y+         nuwTest nuw zres+         nswTest nsw zres+         return (BV.ofResult zres)++    L.UDiv exact ->+      do when (y == BV.zero w)+              (throwError "Division by 0 in constant arithmetic operation")+         let (z,r) = BV.uquotRem x y+         when (exact && r /= BV.zero w)+              (throwError "Exact division failed in constant arithmetic operation")+         return z++    L.SDiv exact ->+      do when (y == BV.zero w)+              (throwError "Division by 0 in constant arithmetic operation")+         when (x == BV.minSigned w && y == BV.mkBV w (-1))+              (throwError "Signed division overflow in constant arithmetic operation")+         let (z,r) = BV.squotRem w x y+         when (exact && r /= BV.zero w )+              (throwError "Exact division failed in constant arithmetic operation")+         return z+    L.URem ->+      do when (y == BV.zero w)+              (throwError "Division by 0 in constant arithmetic operation")+         let r = BV.urem x y+         return r++    L.SRem ->+      do when (y == BV.zero w)+              (throwError "Division by 0 in constant arithmetic operation")+         when (x == BV.minSigned w && y == BV.mkBV w (-1))+              (throwError "Signed division overflow in constant arithmetic operation")+         let r = BV.srem w x y+         return r++    _ -> throwError "Floating point operation applied to integer arguments"++-- BGS: Leave this alone for now, as we don't have a good way to+-- detect overflow from bitvector operations.+-- | Evaluate a bitwise operation on integer values.+evalBitwise ::+  (1 <= w, MonadError String m) =>+  L.BitOp ->+  NatRepr w ->+  BV.BV w -> BV.BV w -> m LLVMConst+evalBitwise op w x y = IntConst w <$>+  let yshf = fromInteger (BV.asUnsigned y) :: Natural+  in case op of+       L.And -> return (BV.and x y)+       L.Or  -> return (BV.or  x y)+       L.Xor -> return (BV.xor x y)+       L.Shl nuw nsw ->+         do let zres = BV.shlOf w x yshf+            when (nuw && BV.ofUnsigned zres)+                 (throwError "Unsigned overflow in left shift")+            when (nsw && BV.ofSigned zres)+                 (throwError "Signed overflow in left shift")+            return (BV.ofResult zres)+       L.Lshr exact ->+         do let z = BV.lshr w x yshf+            when (exact && x /= BV.shl w z yshf)+                 (throwError "Exact right shift failed")+            return z+       L.Ashr exact ->+         do let z = BV.ashr w x yshf+            when (exact && x /= BV.shl w z yshf)+                 (throwError "Exact right shift failed")+            return z++-- | Evaluate a conversion operation on constants.+evalConv ::+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  L.ConstExpr ->+  L.ConvOp ->+  MemType ->+  LLVMConst ->+  m LLVMConst+evalConv expr op mt x = case op of+    L.FpToUi+      | IntType n <- mt+      , Just (Some w) <- someNat n+      , Just LeqProof <- isPosNat w+      , FloatConst f <- x+      -> return $ IntConst w (BV.mkBV w (truncate f))++      | IntType n <- mt+      , Just (Some w) <- someNat n+      , Just LeqProof <- isPosNat w+      , DoubleConst d <- x+      -> return $ IntConst w (BV.mkBV w (truncate d))++    L.FpToSi+      | IntType n <- mt+      , Just (Some w) <- someNat n+      , Just LeqProof <- isPosNat w+      , FloatConst f <- x+      -> return $ IntConst w (BV.mkBV w (truncate f))++      | IntType n <- mt+      , Just (Some w) <- someNat n+      , Just LeqProof <- isPosNat w+      , DoubleConst d <- x+      -> return $ IntConst w (BV.mkBV w (truncate d))++    L.UiToFp+      | FloatType <- mt+      , IntConst _w i <- x+      -> return $ FloatConst (fromInteger (BV.asUnsigned i) :: Float)++      | DoubleType <- mt+      , IntConst _w i <- x+      -> return $ DoubleConst (fromInteger (BV.asUnsigned i) :: Double)++    L.SiToFp+      | FloatType <- mt+      , IntConst w i <- x+      -> return $ FloatConst (fromInteger (BV.asSigned w i) :: Float)++      | DoubleType <- mt+      , IntConst w i <- x+      -> return $ DoubleConst (fromInteger (BV.asSigned w i) :: Double)++    L.Trunc+      | IntType n <- mt+      , IntConst w i <- x+      , Just (Some w') <- someNat n+      , Just LeqProof <- isPosNat w'+      -> case testNatCases w' w of+          NatCaseLT LeqProof -> return $ IntConst w' (BV.trunc w' i)+          NatCaseEQ -> return x+          NatCaseGT LeqProof ->+            throwError $ "Attempted to truncate " <> show w <> " bits to " <> show w'++    L.ZExt+      | IntType n <- mt+      , IntConst w i <- x+      , Just (Some w') <- someNat n+      , Just LeqProof <- isPosNat w'+      -> case testNatCases w w' of+          NatCaseLT LeqProof -> return $ IntConst w' (BV.zext w' i)+          NatCaseEQ -> return x+          NatCaseGT LeqProof ->+            throwError $ "Attempted to zext " <> show w <> " bits to " <> show w'++    L.SExt+      | IntType n <- mt+      , IntConst w i <- x+      , Just (Some w') <- someNat n+      , Just LeqProof <- isPosNat w'+      -> case testNatCases w w' of+          NatCaseLT LeqProof -> return $ IntConst w' (BV.sext w w' i)+          NatCaseEQ -> return x+          NatCaseGT LeqProof ->+            throwError $ "Attempted to sext " <> show w <> " bits to " <> show w'++    L.FpTrunc+      | DoubleType <- mt+      , DoubleConst d <- x+      -> return $ DoubleConst d++      | FloatType <- mt+      , DoubleConst d <- x+      -> return $ FloatConst (realToFrac d)++      | FloatType <- mt+      , FloatConst f <- x+      -> return $ FloatConst f++    L.FpExt+      | DoubleType <- mt+      , DoubleConst d <- x+      -> return $ DoubleConst d++      | DoubleType <- mt+      , FloatConst f <- x+      -> return $ DoubleConst (realToFrac f)++      | FloatType <- mt+      , FloatConst f <- x+      -> return $ FloatConst f++    L.IntToPtr -> return x+    L.PtrToInt -> return x++    _ -> badExp "unexpected conversion operation"++ where badExp msg = throwError $ unlines [msg, show expr]+++castToInt ::+  MonadError String m =>+  L.ConstExpr {- ^ original expression to evaluate -} ->+  EndianForm ->+  Natural ->+  MemType ->+  LLVMConst ->+  m Integer+castToInt _expr _endian _w (IntType w) x = asInt w x+castToInt expr endian w (VecType n tp) x+  | (m,0) <- w `divMod` n =+  do xs <- asVectorOf n (castToInt expr endian m tp) x+     let indices = case endian of+                     LittleEndian -> [0 .. n-1]+                     BigEndian -> reverse [0 .. n-1]+     let pieces = [ v `shiftL` (fromIntegral (i * m))+                  | i <- indices+                  | v <- xs+                  ]+     return (foldr (.|.) 0 pieces)++castToInt expr _ _ _ _ =+  throwError $ unlines ["Cannot cast expression to integer type", show expr]++castFromInt ::+  MonadError String m =>+  EndianForm ->+  Integer ->+  Natural ->+  MemType ->+  m LLVMConst+castFromInt _ xint w (IntType w')+  | w == w'+  , Some wsz <- mkNatRepr w+  , Just LeqProof <- isPosNat wsz+  = return $ IntConst wsz (BV.mkBV wsz xint)++castFromInt endian xint w (VecType n tp)+  | (m,0) <- w `divMod` n =+  do let mask = (1 `shiftL` fromIntegral m) - 1+     let indices = case endian of+                     LittleEndian -> [0 .. n-1]+                     BigEndian -> reverse [0 .. n-1]+     let pieces = [ mask .&. (xint `shiftR` fromIntegral (i * m))+                  | i <- indices+                  ]+     VectorConst tp <$> mapM (\x -> castFromInt endian x m tp) pieces++castFromInt _ _ _ tp =+  throwError $ unlines ["Cant cast integer to type", show tp]++-- | Evaluate a bitcast+evalBitCast ::+  (?lc :: TypeContext, MonadError String m) =>+  L.ConstExpr {- ^ original expression to evaluate -} ->+  MemType     {- ^ input expressio type -} ->+  LLVMConst   {- ^ input expression -} ->+  MemType     {- ^ desired output type -} ->+  m LLVMConst++-- cast zero constants to relabeled zero constants+evalBitCast _ _ (ZeroConst _) tgtT = return (ZeroConst tgtT)++-- pointer casts always succeed+evalBitCast _ (PtrType _) expr (PtrType _) = return expr+evalBitCast _ (PtrType _) expr PtrOpaqueType = return expr+evalBitCast _ PtrOpaqueType expr (PtrType _) = return expr+evalBitCast _ PtrOpaqueType expr PtrOpaqueType = return expr++-- casts between vectors of the same length can just be done pointwise+evalBitCast expr (VecType n srcT) (VectorConst _ xs) (VecType n' tgtT)+  | n == n' = VectorConst tgtT <$> traverse (\x -> evalBitCast expr srcT x tgtT) xs++-- otherwise, cast via an intermediate integer type+evalBitCast expr xty x toty+  | Just w1 <- memTypeBitwidth xty+  , Just w2 <- memTypeBitwidth toty+  , w1 == w2+  = do let endian = ?lc ^. to llvmDataLayout.intLayout+       xint <- castToInt expr endian w1 xty x+       castFromInt endian xint w1 toty++evalBitCast expr _ _ _ =+   throwError $ unlines ["illegal constant bitcast", show expr]+++asVectorOf ::+  MonadError String m =>+  Natural ->+  (LLVMConst -> m a) ->+  (LLVMConst -> m [a])+asVectorOf n f (ZeroConst (VecType m mt))+  | n == m+  = do x <- f (ZeroConst mt)+       return (replicate (fromIntegral n) x)++asVectorOf n f (VectorConst _ xs)+  | n == fromIntegral (length xs)+  = traverse f xs++asVectorOf n _ _+  = throwError ("Expected vector constant value of length: " ++ show n)++-- | Type representing integer-like things.  These are either actual+--   integer constants, or constant offsets from global symbols.+data ArithInt where+  ArithInt :: Integer -> ArithInt+  ArithPtr :: L.Symbol -> Integer -> ArithInt++-- | A constant value to which arithmetic operation can be applied.+--   These are integers, pointers, floats and doubles.+data Arith where+  ArithI :: ArithInt -> Arith+  ArithF :: Float -> Arith+  ArithD :: Double -> Arith++asArithInt ::+  (MonadError String m, HasPtrWidth wptr) =>+  Natural   {- ^ expected integer width -} ->+  LLVMConst {- ^ constant value -} ->+  m ArithInt+asArithInt n (ZeroConst (IntType m))+  | n == m+  = return (ArithInt 0)+asArithInt n (IntConst w x)+  | n == natValue w+  = return (ArithInt (BV.asUnsigned x))+asArithInt n (SymbolConst sym off)+  | n == natValue ?ptrWidth+  = return (ArithPtr sym off)+asArithInt _ _+  = throwError "Expected integer value"++asArith ::+  (MonadError String m, HasPtrWidth wptr) =>+  MemType   {- ^ expected type -} ->+  LLVMConst {- ^ constant value -} ->+  m Arith+asArith (IntType n) x = ArithI <$> asArithInt n x+asArith FloatType x   = ArithF <$> asFloat x+asArith DoubleType x  = ArithD <$> asDouble x+asArith _ _ = throwError "Expected arithmetic type"++asInt ::+  MonadError String m =>+  Natural   {- ^ expected integer width -} ->+  LLVMConst {- ^ constant value -} ->+  m Integer+asInt n (ZeroConst (IntType m))+  | n == m+  = return 0+asInt n (IntConst w x)+  | n == natValue w+  = return (BV.asUnsigned x)+asInt n _+  = throwError ("Expected integer constant of size " ++ show n)++asBV ::+  MonadError String m =>+  NatRepr w {- ^ expected integer width -} ->+  LLVMConst {- ^ constant value -} ->+  m (BV.BV w)+asBV w (ZeroConst (IntType m))+  | natValue w == m+  = return (BV.zero w)+asBV w (IntConst w' x)+  | Just Refl <- w `testEquality` w'+  = return x+asBV w _+  = throwError ("Expected integer constant of size " ++ show w)++asFloat ::+  MonadError String m =>+  LLVMConst {- ^ constant value -} ->+  m Float+asFloat (ZeroConst FloatType) = return 0+asFloat (FloatConst x) = return x+asFloat _ = throwError "Expected floating point constant"++asDouble ::+  MonadError String m =>+  LLVMConst {- ^ constant value -} ->+  m Double+asDouble (ZeroConst DoubleType) = return 0+asDouble (DoubleConst x) = return x+asDouble _ = throwError "Expected double constant"+++-- | Compute the value of a constant expression.  Fails if+--   the expression does not actually represent a constant value.+transConstantExpr :: forall m wptr.+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  L.ConstExpr ->+  m LLVMConst+transConstantExpr expr = case expr of+  L.ConstGEP inbounds _inrange baseTy base exps -> -- TODO? pay attention to the inrange flag+    do gep <- translateGEP inbounds baseTy base exps+       gep' <- traverse transConstant gep+       snd <$> evalConstGEP gep'++  L.ConstSelect b x y ->+    do b' <- transConstant b+       x' <- transConstant x+       y' <- transConstant y+       case b' of+         IntConst w v+           | v /= BV.zero w -> return x'+           | otherwise      -> return y'+         _ -> badExp "Expected boolean value in constant select"++  L.ConstBlockAddr _ _ ->+    badExp "constant block addresses not supported"++  L.ConstFCmp op a b ->+    do mt <- liftMemType (L.typedType a)+       case mt of+         VecType n FloatType ->+           do a' <- asVectorOf n asFloat =<< transConstant a+              b' <- asVectorOf n asFloat =<< transConstant b+              return $ VectorConst (IntType 1) $ zipWith (evalFcmp op) a' b'+         VecType n DoubleType ->+           do a' <- asVectorOf n asDouble =<< transConstant a+              b' <- asVectorOf n asDouble =<< transConstant b+              return $ VectorConst (IntType 1) $ zipWith (evalFcmp op) a' b'+         FloatType ->+           do a' <- asFloat =<< transConstant a+              b' <- asFloat =<< transConstant b+              return $ evalFcmp op a' b'+         DoubleType ->+           do a' <- asDouble =<< transConstant a+              b' <- asDouble =<< transConstant b+              return $ evalFcmp op a' b'+         _ -> badExp "Expected floating point arguments"++  L.ConstICmp op a b ->+    do mt <- liftMemType (L.typedType a)+       case mt of+         VecType n (IntType m)+           | Some w <- mkNatRepr m+           , Just LeqProof <- isPosNat w+           -> do a' <- asVectorOf n (asBV w) =<< transConstant a+                 b' <- asVectorOf n (asBV w) =<< transConstant b+                 return $ VectorConst (IntType 1) $ zipWith (evalIcmp op w) a' b'+         IntType m+           | Some w <- mkNatRepr m+           , Just LeqProof <- isPosNat w+           -> do a' <- asBV w =<< transConstant a+                 b' <- asBV w =<< transConstant b+                 return $ evalIcmp op w a' b'+         _ -> badExp "Expected integer arguments"++  L.ConstArith op (L.Typed tp a) b ->+    do mt <- liftMemType tp+       case mt of+          VecType n tp' ->+            do a' <- asVectorOf n (asArith tp') =<< transConstant' mt a+               b' <- asVectorOf n (asArith tp') =<< transConstant' mt b+               VectorConst tp' <$> zipWithM (evalArith op tp') a' b'+          tp' ->+            do a' <- asArith tp' =<< transConstant' mt a+               b' <- asArith tp' =<< transConstant' mt b+               evalArith op tp' a' b'++  L.ConstUnaryArith op (L.Typed tp a) ->+    do mt <- liftMemType tp+       case mt of+          VecType n tp' ->+            do a' <- asVectorOf n (asArith tp') =<< transConstant' mt a+               VectorConst tp' <$> traverse (evalUnaryArith op tp') a'+          tp' ->+            do a' <- asArith tp' =<< transConstant' mt a+               evalUnaryArith op tp' a'++  L.ConstBit op (L.Typed tp a) b ->+    do mt <- liftMemType tp+       case mt of+         VecType n (IntType m)+           | Some w <- mkNatRepr m+           , Just LeqProof <- isPosNat w+           -> do a' <- asVectorOf n (asBV w) =<< transConstant' mt a+                 b' <- asVectorOf n (asBV w) =<< transConstant' mt b+                 VectorConst (IntType m) <$> zipWithM (evalBitwise op w) a' b'+         IntType m+           | Some w <- mkNatRepr m+           , Just LeqProof <- isPosNat w+           -> do a' <- asBV w =<< transConstant' mt a+                 b' <- asBV w =<< transConstant' mt b+                 evalBitwise op w a' b'+         _ -> badExp "Expected integer arguments"++  L.ConstConv L.BitCast (L.Typed tp x) outty ->+   do toty <- liftMemType outty+      xty  <- liftMemType tp+      x' <- transConstant' xty x+      evalBitCast expr xty x' toty++  L.ConstConv op x outty ->+    do mt <- liftMemType outty+       x' <- transConstant x+       case mt of+         VecType n mt' ->+           do xs <- asVectorOf n return x'+              VectorConst mt' <$> traverse (evalConv expr op mt') xs++         _ -> evalConv expr op mt x'++ where+ badExp :: String -> m a+ badExp msg = throwError $ unlines [msg, show expr]++testBreakpointFunction :: String -> Bool+testBreakpointFunction = isPrefixOf "__breakpoint__"
+ src/Lang/Crucible/LLVM/Translation/Expr.hs view
@@ -0,0 +1,572 @@++-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Expr+-- Description      : Translation-time LLVM expressions+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+-----------------------------------------------------------------------++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ViewPatterns          #-}++module Lang.Crucible.LLVM.Translation.Expr+  ( LLVMExpr(..)+  , ScalarView(..)+  , asScalar+  , asVectorWithType+  , asVector++  , pattern PointerExpr+  , pattern BitvectorAsPointerExpr+  , pointerAsBitvectorExpr++  , unpackOne+  , unpackVec+  , unpackArgs+  , zeroExpand+  , undefExpand+  , explodeVector++  , constToLLVMVal+  , transValue+  , transTypedValue+  , transTypeAndValue+  , liftConstant++  , callIsNull+  , callIntToBool+  , callAlloca+  , callPushFrame+  , callPopFrame+  , callPtrAddOffset+  , callPtrSubtract+  , callLoad+  , callStore+  ) where++import Control.Lens hiding ((:>))+import Control.Monad+import Control.Monad.Except+import qualified Data.ByteString as BS+import Data.Foldable (toList)+import qualified Data.List as List+--import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.String+import qualified Data.Vector as V+import Numeric.Natural+import GHC.Exts ( Proxy#, proxy# )++import qualified Data.BitVector.Sized as BV+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.Context ( pattern (:>) )+import           Data.Parameterized.NatRepr as NatRepr+import           Data.Parameterized.Some+import           Data.Text (Text)++import qualified Text.LLVM.AST as L++import qualified Lang.Crucible.CFG.Core as C+import           Lang.Crucible.CFG.Expr+import           Lang.Crucible.CFG.Generator+import           Lang.Crucible.CFG.Extension ()++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.Translation.Constant+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.Syntax+import           Lang.Crucible.Types++import           What4.InterpretedFloatingPoint (X86_80Val(..))++-------------------------------------------------------------------------+-- LLVMExpr+--+-- As noted in "Lang.Crucible.LLVM.Translation.Types", this code uses+-- a polymorphic continuation-passing style to convert to+-- strongly-typed Crucible types from less-strongly-typed LLVM+-- types. As part of that, the LLVM architecture (notably the pointer+-- width) must be unified between the outer context and the+-- continuation; the 'proxy#' arguments here and below represent a+-- 'Proxy# arch' type that is used to maintain that architecture+-- definition and corresponding pointer width for the conversions.++-- | An intermediate form of LLVM expressions that retains some structure+--   that would otherwise be more difficult to retain if we translated directly+--   into crucible expressions.+data LLVMExpr s (arch :: LLVMArch) where+   BaseExpr   :: TypeRepr tp -> Expr LLVM s tp -> LLVMExpr s arch+   ZeroExpr   :: MemType -> LLVMExpr s arch+   UndefExpr  :: MemType -> LLVMExpr s arch+   VecExpr    :: MemType -> Seq (LLVMExpr s arch) -> LLVMExpr s arch+   StructExpr :: Seq (MemType, LLVMExpr s arch) -> LLVMExpr s arch++instance Show (LLVMExpr s arch) where+  show (BaseExpr ty x)  = C.showF x ++ " : " ++ show ty+  show (ZeroExpr mt)    = "<zero :" ++ show mt ++ ">"+  show (UndefExpr mt)   = "<undef :" ++ show mt ++ ">"+  show (VecExpr _mt xs) = "[" ++ List.intercalate ", " (map show (toList xs)) ++ "]"+  show (StructExpr xs)  = "{" ++ List.intercalate ", " (map f (toList xs)) ++ "}"+    where f (_mt,x) = show x+++data ScalarView s (arch :: LLVMArch) where+  Scalar    :: Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> ScalarView s arch+  NotScalar :: ScalarView s arch++-- | Examine an LLVM expression and return the corresponding+--   crucible expression, if it is a scalar.+asScalar :: (?lc :: TypeContext, HasPtrWidth (ArchWidth arch))+         => LLVMExpr s arch+         -> ScalarView s arch+asScalar (BaseExpr tp xs)+  = Scalar proxy# tp xs+asScalar (ZeroExpr llvmtp)+  = let ?err = error+     in zeroExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex+asScalar (UndefExpr llvmtp)+  = let ?err = error+     in undefExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex+asScalar _ = NotScalar++-- | Turn the expression into an explicit vector.+asVectorWithType :: LLVMExpr s arch -> Maybe (MemType, Seq (LLVMExpr s arch))+asVectorWithType v =+  case v of+    ZeroExpr (VecType n t)  -> Just (t, Seq.replicate (fromIntegral n) (ZeroExpr t))+    UndefExpr (VecType n t) -> Just (t, Seq.replicate (fromIntegral n) (UndefExpr t))+    VecExpr t s             -> Just (t, s)+    _                       -> Nothing++asVector :: LLVMExpr s arch -> Maybe (Seq (LLVMExpr s arch))+asVector = fmap snd . asVectorWithType+++nullPointerExpr :: (HasPtrWidth w) => Expr LLVM s (LLVMPointerType w)+nullPointerExpr = PointerExpr PtrWidth (App (NatLit 0)) (App (BVLit PtrWidth (BV.zero PtrWidth)))++pattern PointerExpr+    :: (1 <= w)+    => NatRepr w+    -> Expr LLVM s NatType+    -> Expr LLVM s (BVType w)+    -> Expr LLVM s (LLVMPointerType w)+pattern PointerExpr w blk off = App (ExtensionApp (LLVM_PointerExpr w blk off))++pattern BitvectorAsPointerExpr+    :: (1 <= w)+    => NatRepr w+    -> Expr LLVM s (BVType w)+    -> Expr LLVM s (LLVMPointerType w)+pattern BitvectorAsPointerExpr w ex = PointerExpr w (App (NatLit 0)) ex++pointerAsBitvectorExpr+    :: (1 <= w)+    => NatRepr w+    -> Expr LLVM s (LLVMPointerType w)+    -> LLVMGenerator s arch ret (Expr LLVM s (BVType w))+pointerAsBitvectorExpr _ (BitvectorAsPointerExpr _ ex) =+     return ex+pointerAsBitvectorExpr w ex =+  do ex' <- forceEvaluation ex+     let blk = App (ExtensionApp (LLVM_PointerBlock w ex'))+     let off = App (ExtensionApp (LLVM_PointerOffset w ex'))+     assertExpr (blk .== litExpr 0)+                (litExpr "Expected bitvector, but found pointer")+     return off++++-- | Given a list of LLVMExpressions, "unpack" them into an assignment+--   of crucible expressions.+unpackArgs :: forall s a arch+    . (?err :: String -> a+      ,HasPtrWidth (ArchWidth arch)+      )+   => [LLVMExpr s arch]+   -> (forall ctx. Proxy# arch -> CtxRepr ctx -> Ctx.Assignment (Expr LLVM s) ctx -> a)+   -> a+unpackArgs = go Ctx.Empty Ctx.Empty+ where go :: CtxRepr ctx+          -> Ctx.Assignment (Expr LLVM s) ctx+          -> [LLVMExpr s arch]+          -> (forall ctx'. Proxy# arch -> CtxRepr ctx' -> Ctx.Assignment (Expr LLVM s) ctx' -> a)+          -> a+       go ctx asgn [] k = k proxy# ctx asgn+       go ctx asgn (v:vs) k = unpackOne v (\_ tyr ex -> go (ctx :> tyr) (asgn :> ex) vs k)++unpackOne+   :: (?err :: String -> a, HasPtrWidth (ArchWidth arch))+   => LLVMExpr s arch+   -> (forall tpr. Proxy# arch -> TypeRepr tpr -> Expr LLVM s tpr -> a)+   -> a+unpackOne (BaseExpr tyr ex) k = k proxy# tyr ex+unpackOne (UndefExpr tp) k = undefExpand proxy# tp k+unpackOne (ZeroExpr tp) k = zeroExpand proxy# tp k+unpackOne (StructExpr vs) k =+  unpackArgs (map snd $ toList vs) $ \archProxy struct_ctx struct_asgn ->+      k archProxy (StructRepr struct_ctx) (mkStruct struct_ctx struct_asgn)+unpackOne (VecExpr tp vs) k =+  llvmTypeAsRepr tp $ \tpr -> unpackVec proxy# tpr (toList vs) $ k proxy# (VectorRepr tpr)++unpackVec :: forall tpr s arch a+    . ( ?err :: String -> a+      , HasPtrWidth (ArchWidth arch)+      )+   => Proxy# arch+   -> TypeRepr tpr+   -> [LLVMExpr s arch]+   -> (Expr LLVM s (VectorType tpr) -> a)+   -> a+unpackVec _archProxy tpr = go [] . reverse+  where go :: [Expr LLVM s tpr] -> [LLVMExpr s arch] -> (Expr LLVM s (VectorType tpr) -> a) -> a+        go vs [] k = k (vectorLit tpr $ V.fromList vs)+        go vs (x:xs) k = unpackOne x $ \_archProxy' tpr' v ->+                           case testEquality tpr tpr' of+                             Just Refl -> go (v:vs) xs k+                             Nothing -> ?err $ unwords ["type mismatch in array value", show tpr, show tpr']++zeroExpand :: (?err :: String -> a, HasPtrWidth (ArchWidth arch))+           => Proxy# arch+           -> MemType+           -> (forall tp. Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> a)+           -> a+zeroExpand _proxyArch (IntType w) k =+  case mkNatRepr w of+    Some w' | Just LeqProof <- isPosNat w' ->+      k proxy# (LLVMPointerRepr w') $+         BitvectorAsPointerExpr w' $+         App $ BVLit w' (BV.zero w')++    _ -> ?err $ unwords ["illegal integer size", show w]++zeroExpand _proxyArch (StructType si) k =+   unpackArgs (map ZeroExpr tps) $ \archProxy ctx asgn -> k archProxy (StructRepr ctx) (mkStruct ctx asgn)+ where tps = map fiType $ toList $ siFields si+zeroExpand proxyArch (ArrayType n tp) k =+  llvmTypeAsRepr tp $ \tpr -> unpackVec proxyArch tpr (replicate (fromIntegral n) (ZeroExpr tp)) $ k proxyArch (VectorRepr tpr)+zeroExpand proxyArch (VecType n tp) k =+  llvmTypeAsRepr tp $ \tpr -> unpackVec proxyArch tpr (replicate (fromIntegral n) (ZeroExpr tp)) $ k proxyArch (VectorRepr tpr)+zeroExpand proxyArch (PtrType _tp) k = k proxyArch PtrRepr nullPointerExpr+zeroExpand proxyArch PtrOpaqueType k = k proxyArch PtrRepr nullPointerExpr+zeroExpand proxyArch FloatType   k  = k proxyArch (FloatRepr SingleFloatRepr) (App (FloatLit 0))+zeroExpand proxyArch DoubleType  k  = k proxyArch (FloatRepr DoubleFloatRepr) (App (DoubleLit 0))+zeroExpand _prxyArch X86_FP80Type _ = ?err "Cannot zero expand x86_fp80 values"+zeroExpand _prxyArch MetadataType _ = ?err "Cannot zero expand metadata"++undefExpand :: ( ?err :: String -> a+               , HasPtrWidth (ArchWidth arch)+               )+            => Proxy# arch+            -> MemType+            -> (forall tp. Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> a)+            -> a+undefExpand _archProxy (IntType w) k =+  case mkNatRepr w of+    Some w' | Just LeqProof <- isPosNat w' ->+      k proxy# (LLVMPointerRepr w') $+         BitvectorAsPointerExpr w' $+         App $ BVUndef w'++    _ -> ?err $ unwords ["illegal integer size", show w]+undefExpand _archProxy (PtrType _tp) k =+   k proxy# PtrRepr $ BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth+undefExpand _archProxy PtrOpaqueType k =+   k proxy# PtrRepr $ BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth+undefExpand _archProxy (StructType si) k =+   unpackArgs (map UndefExpr tps) $ \archProxy ctx asgn -> k archProxy (StructRepr ctx) (mkStruct ctx asgn)+ where tps = map fiType $ toList $ siFields si+undefExpand archProxy (ArrayType n tp) k =+  llvmTypeAsRepr tp $ \tpr -> unpackVec archProxy tpr (replicate (fromIntegral n) (UndefExpr tp)) $ k proxy# (VectorRepr tpr)+undefExpand archProxy (VecType n tp) k =+  llvmTypeAsRepr tp $ \tpr -> unpackVec archProxy tpr (replicate (fromIntegral n) (UndefExpr tp)) $ k proxy# (VectorRepr tpr)+undefExpand _archProxy FloatType k =+  k proxy# (FloatRepr SingleFloatRepr) (App (FloatUndef SingleFloatRepr))+undefExpand _archProxy DoubleType k =+  k proxy# (FloatRepr DoubleFloatRepr) (App (FloatUndef DoubleFloatRepr))+undefExpand _archProxy X86_FP80Type k =+  k proxy# (FloatRepr X86_80FloatRepr) (App (FloatUndef X86_80FloatRepr))+undefExpand _archPrxy tp _ = ?err $ unwords ["cannot undef expand type:", show tp]+++explodeVector :: Natural -> LLVMExpr s arch -> Maybe (Seq (LLVMExpr s arch))+explodeVector n (UndefExpr (VecType n' tp)) | n == n' = return (Seq.replicate (fromIntegral n) (UndefExpr tp))+explodeVector n (ZeroExpr (VecType n' tp)) | n == n' = return (Seq.replicate (fromIntegral n) (ZeroExpr tp))+explodeVector n (VecExpr _tp xs)+  | n == fromIntegral (length xs) = return xs+explodeVector n (BaseExpr (VectorRepr tpr) v) =+    let xs = [ BaseExpr tpr (app $ VectorGetEntry tpr v (litExpr i)) | i <- [0..n-1] ]+     in return (Seq.fromList xs)+explodeVector _ _ = Nothing+++---------------------------------------------------------------------------+-- Translations++liftConstant ::+  HasPtrWidth (ArchWidth arch) =>+  LLVMConst ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+liftConstant c = case c of+  ZeroConst mt ->+    return $ ZeroExpr mt+  UndefConst mt ->+    return $ UndefExpr mt+  IntConst w i ->+    return $ BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w (App (BVLit w i)))+  FloatConst f ->+    return $ BaseExpr (FloatRepr SingleFloatRepr) (App (FloatLit f))+  DoubleConst d ->+    return $ BaseExpr (FloatRepr DoubleFloatRepr) (App (DoubleLit d))+  LongDoubleConst (L.FP80_LongDouble ex man) ->+    return $ BaseExpr (FloatRepr X86_80FloatRepr) (App (X86_80Lit (X86_80Val ex man)))+  StringConst bs ->+    -- TODO? Should we have a StringExpr? It seems like this case doesn't+    --  actually ever arise...+    do vs <- mapM (\b -> liftConstant (IntConst knownNat (BV.word8 b))) (BS.unpack bs)+       return (VecExpr i8 $ Seq.fromList vs)+  ArrayConst mt vs ->+    do vs' <- mapM (\c' -> liftConstant c') vs+       return (VecExpr mt $ Seq.fromList vs')+  VectorConst mt vs ->+    do vs' <- mapM (\c' -> liftConstant c') vs+       return (VecExpr mt $ Seq.fromList vs')+  StructConst si vs ->+    do vs' <- mapM (\c' -> liftConstant c') vs+       let ts = map fiType $ V.toList (siFields si)+       unless (length vs' == length ts)+              (fail "Type mismatch in structure constant")+       return (StructExpr (Seq.fromList (zip ts vs')))+  SymbolConst sym 0 ->+    do memVar <- getMemVar+       base <- extensionStmt (LLVM_ResolveGlobal ?ptrWidth memVar (GlobalSymbol sym))+       return (BaseExpr PtrRepr base)+  SymbolConst sym off ->+    do memVar <- getMemVar+       base <- extensionStmt (LLVM_ResolveGlobal ?ptrWidth memVar (GlobalSymbol sym))+       let off' = app $ BVLit ?ptrWidth (BV.mkBV ?ptrWidth off)+       ptr  <- extensionStmt (LLVM_PtrAddOffset ?ptrWidth memVar base off')+       return (BaseExpr PtrRepr ptr)++transTypeAndValue ::+  L.Typed L.Value ->+  LLVMGenerator s arch ret (MemType, LLVMExpr s arch)+transTypeAndValue v =+ do let err msg =+         malformedLLVMModule+           "Invalid value type"+           [ fromString msg ]+    tp <- either err return $ liftMemType $ L.typedType v+    (\ex -> (tp, ex)) <$> transValue tp (L.typedValue v)++transTypedValue ::+  L.Typed L.Value ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+transTypedValue v = snd <$> transTypeAndValue v++-- | Translate an LLVM Value into an expression.+transValue :: forall s arch ret.+              MemType+           -> L.Value+           -> LLVMGenerator s arch ret (LLVMExpr s arch)++transValue ty L.ValUndef =+  return $ UndefExpr ty++transValue ty L.ValZeroInit =+  return $ ZeroExpr ty++transValue ty@(PtrType _) L.ValNull =+  return $ ZeroExpr ty+transValue ty@PtrOpaqueType L.ValNull =+  return $ ZeroExpr ty++transValue ty@(PtrType _) (L.ValInteger 0) =+  return $ ZeroExpr ty+transValue ty@PtrOpaqueType (L.ValInteger 0) =+  return $ ZeroExpr ty++transValue ty@(PtrType _) v@(L.ValInteger _) =+  reportError $ fromString $ unwords ["Attempted to use integer ", show v, " as pointer: ", show ty]+transValue ty@PtrOpaqueType v@(L.ValInteger _) =+  reportError $ fromString $ unwords ["Attempted to use integer ", show v, " as pointer: ", show ty]++transValue ty@(IntType _) L.ValNull =+  return $ ZeroExpr ty++transValue _ (L.ValString str) = do+  let eight = knownNat :: NatRepr 8+  let bv8   = LLVMPointerRepr eight+  let chars = V.fromList $ map (BitvectorAsPointerExpr eight . App . BVLit eight . BV.mkBV eight . toInteger . fromEnum) $ str+  return $ BaseExpr (VectorRepr bv8) (App $ VectorLit bv8 $ chars)++transValue _ (L.ValIdent i) = do+  m <- use identMap+  case Map.lookup i m of+    Nothing -> do+      reportError $ fromString $ "Could not find identifier " ++ show i ++ "."+    Just (Left (Some r)) -> do+      e <- readReg r+      return $ BaseExpr (typeOfReg r) e+    Just (Right (Some a)) -> do+      return $ BaseExpr (typeOfAtom a) (AtomExpr a)++transValue (IntType n) (L.ValInteger i) =+  runExceptT (intConst n i) >>= \case+    Left err -> fail err+    Right c  -> liftConstant c++transValue (IntType 1) (L.ValBool b) =+  liftConstant (boolConst b)++transValue FloatType (L.ValFloat f) =+  liftConstant (FloatConst f)++transValue DoubleType (L.ValDouble d) =+  liftConstant (DoubleConst d)++transValue (StructType _) (L.ValStruct vs) = do+     vs' <- mapM (\v -> transTypeAndValue v) vs+     return (StructExpr $ Seq.fromList $ vs')++transValue (StructType _) (L.ValPackedStruct vs) =  do+     vs' <- mapM (\v -> transTypeAndValue v) vs+     return (StructExpr $ Seq.fromList $ vs')++transValue (ArrayType _ tp) (L.ValArray _ vs) = do+     vs' <- mapM (\v -> transValue tp v) vs+     return (VecExpr tp $ Seq.fromList vs')++transValue (VecType _ tp) (L.ValVector _ vs) = do+     vs' <- mapM (\v -> transValue tp v) vs+     return (VecExpr tp $ Seq.fromList vs')++transValue _ (L.ValSymbol symbol) = do+     liftConstant (SymbolConst symbol 0)++transValue _ (L.ValConstExpr cexp) =+  do res <- runExceptT (transConstantExpr cexp)+     case res of+       Left err -> reportError $ fromString $ unlines ["Error translating constant", err]+       Right cv -> liftConstant cv++transValue ty v =+  reportError $ fromString $ unwords ["unsupported LLVM value:", show v, "of type", show ty]+++callIsNull+   :: (1 <= w)+   => NatRepr w+   -> Expr LLVM s (LLVMPointerType w)+   -> LLVMGenerator s arch ret (Expr LLVM s BoolType)+callIsNull w ex = App . Not <$> callIntToBool w ex++callIntToBool+  :: (1 <= w)+  => NatRepr w+  -> Expr LLVM s (LLVMPointerType w)+  -> LLVMGenerator s arch ret (Expr LLVM s BoolType)+callIntToBool w (BitvectorAsPointerExpr _ bv) =+  case bv of+    App (BVLit _ i) -> if i == BV.zero w then return false else return true+    _ -> return (App (BVNonzero w bv))+callIntToBool w ex =+  do ex' <- forceEvaluation ex+     let blk = App (ExtensionApp (LLVM_PointerBlock w ex'))+     let off = App (ExtensionApp (LLVM_PointerOffset w ex'))+     return (blk ./= litExpr 0 .|| (App (BVNonzero w off)))++callAlloca+   :: wptr ~ ArchWidth arch+   => Expr LLVM s (BVType wptr)+   -> Alignment+   -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+callAlloca sz alignment = do+   memVar <- getMemVar+   loc <- show <$> getPosition+   extensionStmt (LLVM_Alloca ?ptrWidth memVar sz alignment loc)++callPushFrame :: Text -> LLVMGenerator s arch ret ()+callPushFrame nm = do+   memVar <- getMemVar+   void $ extensionStmt (LLVM_PushFrame nm memVar)++callPopFrame :: LLVMGenerator s arch ret ()+callPopFrame = do+   memVar <- getMemVar+   void $ extensionStmt (LLVM_PopFrame memVar)++callPtrAddOffset ::+       wptr ~ ArchWidth arch+    => Expr LLVM s (LLVMPointerType wptr)+    -> Expr LLVM s (BVType wptr)+    -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+callPtrAddOffset base off = do+    memVar <- getMemVar+    extensionStmt (LLVM_PtrAddOffset ?ptrWidth memVar base off)++callPtrSubtract ::+       wptr ~ ArchWidth arch+    => Expr LLVM s (LLVMPointerType wptr)+    -> Expr LLVM s (LLVMPointerType wptr)+    -> LLVMGenerator s arch ret (Expr LLVM s (BVType wptr))+callPtrSubtract x y = do+    memVar <- getMemVar+    extensionStmt (LLVM_PtrSubtract ?ptrWidth memVar x y)++callLoad :: MemType+         -> TypeRepr tp+         -> LLVMExpr s arch+         -> Alignment+         -> LLVMGenerator s arch ret (LLVMExpr s arch)+callLoad typ expectTy (asScalar -> Scalar _ PtrRepr ptr) align =+   do memVar <- getMemVar+      typ' <- toStorableType typ+      v <- extensionStmt (LLVM_Load memVar ptr expectTy typ' align)+      return (BaseExpr expectTy v)+callLoad _ _ _ _ =+  fail $ unwords ["Unexpected argument type in callLoad"]++callStore :: MemType+          -> LLVMExpr s arch+          -> LLVMExpr s arch+          -> Alignment+          -> LLVMGenerator s arch ret ()+callStore typ (asScalar -> Scalar _ PtrRepr ptr) (ZeroExpr _mt) _align =+ do memVar <- getMemVar+    typ'   <- toStorableType typ+    void $ extensionStmt (LLVM_MemClear memVar ptr (storageTypeSize typ'))++callStore typ (asScalar -> Scalar _ PtrRepr ptr) v align =+ do let ?err = fail+    unpackOne v $ \_ vtpr vexpr -> do+      memVar <- getMemVar+      typ' <- toStorableType typ+      void $ extensionStmt (LLVM_Store memVar ptr vtpr typ' align vexpr)++callStore _ _ _ _ =+  fail $ unwords ["Unexpected argument type in callStore"]
+ src/Lang/Crucible/LLVM/Translation/Instruction.hs view
@@ -0,0 +1,2109 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Instruction+-- Description      : Translation of LLVM instructions+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+-- This module represents the workhorse of the LLVM translation.  It+-- is responsible for interpreting the LLVM instruction set into+-- corresponding crucible statements.+-----------------------------------------------------------------------++{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ViewPatterns          #-}++module Lang.Crucible.LLVM.Translation.Instruction+  ( instrResultType+  , generateInstr+  , definePhiBlock+  , assignLLVMReg+  , callOrdinaryFunction+  ) where++import           Prelude hiding (exp, pred)++import           Control.Lens hiding (op, (:>) )+import           Control.Monad (MonadPlus(..), forM, unless)+import           Control.Monad.Except (MonadError(..), runExceptT)+import           Control.Monad.State.Strict (MonadState(..))+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Maybe+import           Data.Foldable (for_, toList)+import           Data.Functor (void)+import           Data.Int+import qualified Data.List as List+import           Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.Map.Strict as Map+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import           Data.String+import qualified Data.Text as Text+import qualified Data.Vector as V+import           Numeric.Natural+import           Prettyprinter (pretty)+import GHC.Exts ( Proxy#, proxy# )++import qualified Text.LLVM.AST as L++import qualified Data.BitVector.Sized as BV+import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr as NatRepr+import           Data.Parameterized.Some++import           What4.Utils.StringLiteral++import           Lang.Crucible.CFG.Expr+import           Lang.Crucible.CFG.Generator++import qualified Lang.Crucible.LLVM.Bytes as G+import           Lang.Crucible.LLVM.DataLayout+import qualified Lang.Crucible.LLVM.Errors.Poison as Poison+import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemType+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import           Lang.Crucible.LLVM.Translation.Constant+import           Lang.Crucible.LLVM.Translation.Expr+import           Lang.Crucible.LLVM.Translation.Monad+import           Lang.Crucible.LLVM.Translation.Options+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext+import           Lang.Crucible.Syntax hiding (IsExpr)+import           Lang.Crucible.Types++--------------------------------------------------------------------------------+-- Assertions++-- | Add a bunch of side conditions to a value.+--+-- Allows for effectful computation of the predicates and expressions.+sideConditionsA :: forall f ty s. Applicative f+                => GlobalVar Mem+                -> TypeRepr ty+                -> Expr LLVM s ty+                    -- ^ Expression with side-condition+                -> [( Bool+                    , f (Expr LLVM s BoolType)+                    , UB.UndefinedBehavior (Expr LLVM s)+                    )]+                    -- ^ Conditions to (conditionally) assert+                -> f (Expr LLVM s ty)+sideConditionsA mvar tyRepr expr conds =+  let middle :: Applicative g => (a, g b, c) -> g (a, b, c)+      middle (a, fb, c) = (,,) <$> pure a <*> fb <*> pure c++      fmapMaybe :: Functor g => g [a] -> (a -> Maybe b) -> g [b]+      fmapMaybe gs h = fmap (mapMaybe h) gs++      conds' :: f [LLVMSideCondition (Expr LLVM s)]+      conds' = fmapMaybe (traverse middle conds) $ \(b, pred, classifier) ->+                (if b then Just else const Nothing) $+                  LLVMSideCondition pred classifier+  in flip fmap conds' $+      \case+        []     -> expr -- No assertions left, nothing to do.+        (x:xs) -> App $ ExtensionApp $ LLVM_SideConditions mvar tyRepr (x :| xs) expr++-- | Assert that evaluation doesn't result in a poison value+poisonSideCondition :: GlobalVar Mem+                    -> TypeRepr ty+                    -> Poison.Poison (Expr LLVM s)+                    -> Expr LLVM s ty+                       -- ^ Expression with side-condition+                    -> Expr LLVM s BoolType+                       -- ^ Condition to assert+                    -> Expr LLVM s ty+poisonSideCondition mvar tyRepr poison expr cond =+  runIdentity $ sideConditionsA mvar tyRepr expr [(True, pure cond, UB.PoisonValueCreated poison)]++--------------------------------------------------------------------------------+-- Translation++-- | Get the return type of an LLVM instruction+-- See <https://llvm.org/docs/LangRef.html#instruction-reference the language reference>.+instrResultType ::+  (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) =>+  L.Instr ->+  m MemType+instrResultType instr =+  case instr of+    L.Arith _ x _ -> liftMemType (L.typedType x)+    L.UnaryArith _ x -> liftMemType (L.typedType x)+    L.Bit _ x _   -> liftMemType (L.typedType x)+    L.Conv _ _ ty -> liftMemType ty+    L.Call _ (L.FunTy ty _ _) _ _ -> liftMemType ty+    L.Call _ ty _ _ -> throwError $ unwords ["unexpected non-function type in call:", show ty]+    L.Invoke (L.FunTy ty _ _) _ _ _ _ -> liftMemType ty+    L.Invoke ty _ _ _ _ -> throwError $ unwords ["unexpected non-function type in invoke:", show ty]+    L.CallBr (L.FunTy ty _ _) _ _ _ _ -> liftMemType ty+    L.CallBr ty _ _ _ _ -> throwError $ unwords ["unexpected non-function type in callbr:", show ty]+    L.Alloca ty _ _ -> liftMemType (L.PtrTo ty)+    L.Load tp _ _ _ -> liftMemType tp+    L.ICmp _op tv _ -> do+      inpType <- liftMemType (L.typedType tv)+      case inpType of+        VecType len _ -> return (VecType len (IntType 1))+        _ -> return (IntType 1)+    L.FCmp _op tv _ -> do+      inpType <- liftMemType (L.typedType tv)+      case inpType of+        VecType len _ -> return (VecType len (IntType 1))+        _ -> return (IntType 1)+    L.Phi tp _   -> liftMemType tp++    L.GEP inbounds baseTy basePtr elts ->+       do gepRes <- runExceptT (translateGEP inbounds baseTy basePtr elts)+          case gepRes of+            Left err -> throwError err+            Right (GEPResult lanes tp _gep) ->+              let n = natValue lanes in+              if n == 1 then+                return (PtrType (MemType tp))+              else+                return (VecType n (PtrType (MemType tp)))++    L.Select _ x _ -> liftMemType (L.typedType x)++    L.ExtractValue x idxes -> liftMemType (L.typedType x) >>= go idxes+         where go [] tp = return tp+               go (i:is) (ArrayType n tp')+                   | i < fromIntegral n = go is tp'+                   | otherwise = throwError $ unwords ["invalid index into array type", showInstr instr]+               go (i:is) (StructType si) =+                      case siFields si V.!? (fromIntegral i) of+                        Just fi -> go is (fiType fi)+                        Nothing -> throwError $ unwords ["invalid index into struct type", showInstr instr]+               go _ _ = throwError $ unwords ["invalid type in extract value instruction", showInstr instr]++    L.InsertValue x _ _ -> liftMemType (L.typedType x)++    L.ExtractElt x _ ->+       do tp <- liftMemType (L.typedType x)+          case tp of+            VecType _n tp' -> return tp'+            _ -> throwError $ unwords ["extract element of non-vector type", showInstr instr]++    L.InsertElt x _ _ -> liftMemType (L.typedType x)++    L.ShuffleVector x _ i ->+      do xtp <- liftMemType (L.typedType x)+         itp <- liftMemType (L.typedType i)+         case (xtp, itp) of+           (VecType _n ty, VecType m _) -> return (VecType m ty)+           _ -> throwError $ unwords ["invalid shufflevector:", showInstr instr]++    L.LandingPad x _ _ _ -> liftMemType x++    -- LLVM Language Reference: "The original value at the location is returned."+    L.AtomicRW _ _ _ v _ _ -> liftMemType (L.typedType v)++    L.CmpXchg _weak _volatile _ptr _old new _ _ _ ->+      do let dl = llvmDataLayout ?lc+         tp <- liftMemType (L.typedType new)+         return (StructType (mkStructInfo dl False [tp, i1]))++    L.Freeze x -> liftMemType (L.typedType x)++    _ -> throwError $ unwords ["instrResultType, unsupported instruction:", showInstr instr]++-- | Given an LLVM expression of vector type, select out the ith element.+extractElt+    :: forall s arch ret.+       L.Instr+    -> MemType    -- ^ type contained in the vector+    -> Integer   -- ^ size of the vector+    -> LLVMExpr s arch  -- ^ vector expression+    -> LLVMExpr s arch -- ^ index expression+    -> LLVMGenerator s arch ret (LLVMExpr s arch)+extractElt _instr ty _n (UndefExpr _) _i =+   return $ UndefExpr ty+extractElt _instr ty _n (ZeroExpr _) _i =+   return $ ZeroExpr ty+extractElt _ ty _ _ (UndefExpr _) =+   return $ UndefExpr ty+extractElt instr ty n v (ZeroExpr zty) =+   let ?err = fail in+   zeroExpand (proxy# :: Proxy# arch) zty $ \_archProxy tyr ex -> extractElt instr ty n v (BaseExpr tyr ex)+extractElt instr _ n (VecExpr _ vs) i+  | Scalar _archProxy (LLVMPointerRepr _) (BitvectorAsPointerExpr _ x) <- asScalar i+  , App (BVLit _ x') <- x+  = constantExtract (BV.asUnsigned x')++ where+ constantExtract :: Integer -> LLVMGenerator s arch ret (LLVMExpr s arch)+ constantExtract idx =+    if (fromInteger idx < Seq.length vs) && (fromInteger idx < n)+        then return $ Seq.index vs (fromInteger idx)+        else fail (unlines ["invalid extractelement instruction (index out of bounds)", showInstr instr])++extractElt instr ty n (VecExpr _ vs) i = do+   let ?err = fail+   llvmTypeAsRepr ty $ \tyr -> unpackVec (proxy# :: Proxy# arch) tyr (toList vs) $+      \ex -> extractElt instr ty n (BaseExpr (VectorRepr tyr) ex) i+extractElt instr _ n (BaseExpr (VectorRepr tyr) v) i =+  do mvar <- getMemVar+     idx <- case asScalar i of+                   Scalar _archProxy (LLVMPointerRepr w) x ->+                     do bv <- pointerAsBitvectorExpr w x+                        -- The value is poisoned if the index is out of bounds.+                        let poison = Poison.ExtractElementIndex bv+                        return $ poisonSideCondition+                                   mvar+                                   NatRepr+                                   poison+                                   -- returned expression+                                   (App (BvToNat w bv))+                                   -- assertion condition+                                   (App (BVUlt w bv (App (BVLit w (BV.mkBV w n)))))+                   _ ->+                     fail (unlines ["invalid extractelement instruction", showInstr instr])+     return $ BaseExpr tyr (App (VectorGetEntry tyr v idx))++extractElt instr _ _ _ _ = fail (unlines ["invalid extractelement instruction", showInstr instr])+++-- | Given an LLVM expression of vector type, insert a new element at location ith element.+insertElt :: forall s arch ret.+       L.Instr            -- ^ Actual instruction+    -> MemType            -- ^ type contained in the vector+    -> Integer            -- ^ size of the vector+    -> LLVMExpr s arch    -- ^ vector expression+    -> LLVMExpr s arch    -- ^ element to insert+    -> LLVMExpr s arch    -- ^ index expression+    -> LLVMGenerator s arch ret (LLVMExpr s arch)+insertElt _ ty _ _ _ (UndefExpr _) = do+   return $ UndefExpr ty+insertElt instr ty n v a (ZeroExpr zty) = do+   let ?err = fail+   zeroExpand (proxy# :: Proxy# arch) zty $ \_archProxy tyr ex -> insertElt instr ty n v a (BaseExpr tyr ex)++insertElt instr ty n (UndefExpr _) a i  = do+  insertElt instr ty n (VecExpr ty (Seq.replicate (fromInteger n) (UndefExpr ty))) a i+insertElt instr ty n (ZeroExpr _) a i   = do+  insertElt instr ty n (VecExpr ty (Seq.replicate (fromInteger n) (ZeroExpr ty))) a i++insertElt instr _ n (VecExpr ty vs) a i+  | Scalar _archProxy (LLVMPointerRepr _) (BitvectorAsPointerExpr _ x) <- asScalar i+  , App (BVLit _ x') <- x+  = constantInsert (BV.asUnsigned x')+ where+ constantInsert :: Integer -> LLVMGenerator s arch ret (LLVMExpr s arch)+ constantInsert idx =+     if (fromInteger idx < Seq.length vs) && (fromInteger idx < n)+       then return $ VecExpr ty $ Seq.adjust (\_ -> a) (fromIntegral idx) vs+       else fail (unlines ["invalid insertelement instruction (index out of bounds)", showInstr instr])++insertElt instr ty n (VecExpr _ vs) a i = do+   let ?err = fail+   llvmTypeAsRepr ty $ \tyr -> unpackVec (proxy# :: Proxy# arch) tyr (toList vs) $+        \ex -> insertElt instr ty n (BaseExpr (VectorRepr tyr) ex) a i++insertElt instr _ n (BaseExpr (VectorRepr tyr) v) a i =+  do mvar <- getMemVar+     (idx :: Expr LLVM s NatType)+         <- case asScalar i of+                   Scalar _archProxy (LLVMPointerRepr w) x ->+                     do bv <- pointerAsBitvectorExpr w x+                        -- The value is poisoned if the index is out of bounds.+                        let poison = Poison.InsertElementIndex bv+                        return $+                          poisonSideCondition+                            mvar+                            NatRepr+                            poison+                            -- returned expression+                            (App (BvToNat w bv))+                            -- assertion condition+                            (App (BVUlt w bv (App (BVLit w (BV.mkBV w n)))))+                   _ ->+                     fail (unlines ["invalid insertelement instruction", showInstr instr, show i])+     let ?err = fail+     unpackOne a $ \_archProxy tyra a' ->+      case testEquality tyr tyra of+        Just Refl ->+          return $ BaseExpr (VectorRepr tyr) (App (VectorSetEntry tyr v idx a'))+        Nothing -> fail (unlines ["type mismatch in insertelement instruction", showInstr instr])+insertElt instr _tp n v a i = fail (unlines ["invalid insertelement instruction", showInstr instr, show n, show v, show a, show i])++-- Given an LLVM expression of vector or structure type, select out the+-- element indicated by the sequence of given concrete indices.+extractValue+    :: LLVMExpr s arch  -- ^ aggregate expression+    -> [Int32]     -- ^ sequence of indices+    -> LLVMGenerator s arch ret (LLVMExpr s arch)+extractValue v [] = return v+extractValue (UndefExpr (StructType si)) is =+   extractValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, UndefExpr tp)) tps) is+ where tps = map fiType $ toList $ siFields si+extractValue (UndefExpr (ArrayType n tp)) is =+   extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (UndefExpr tp)) is+extractValue (ZeroExpr (StructType si)) is =+   extractValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, ZeroExpr tp)) tps) is+ where tps = map fiType $ toList $ siFields si+extractValue (ZeroExpr (ArrayType n tp)) is =+   extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (ZeroExpr tp)) is+extractValue (StructExpr vs) (i:is)+   | fromIntegral i < Seq.length vs = extractValue (snd $ Seq.index vs $ fromIntegral i) is+extractValue (VecExpr _ vs) (i:is)+   | fromIntegral i < Seq.length vs = extractValue (Seq.index vs $ fromIntegral i) is+extractValue (BaseExpr (StructRepr ctx) x) (i:is)+   | Just (Some idx) <- Ctx.intIndex (fromIntegral i) (Ctx.size ctx) = do+           let tpr = ctx Ctx.! idx+           extractValue (BaseExpr tpr (getStruct idx x)) is+extractValue (BaseExpr (VectorRepr elTp) x) (i:is)+   | i >= 0 =+   do let n = fromIntegral i :: Natural+      extractValue (BaseExpr elTp (app (VectorGetEntry elTp x (litExpr n)))) is+extractValue _ _ = fail "invalid extractValue instruction"+++-- Given an LLVM expression of vector or structure type, insert a new element in the posistion+-- given by the concrete indices.+insertValue+    :: LLVMExpr s arch  -- ^ aggregate expression+    -> LLVMExpr s arch  -- ^ element to insert+    -> [Int32]     -- ^ sequence of concrete indices+    -> LLVMGenerator s arch ret (LLVMExpr s arch)+insertValue _ v [] = return v+insertValue (UndefExpr (StructType si)) v is =+   insertValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, UndefExpr tp)) tps) v is+ where tps = map fiType $ toList $ siFields si+insertValue (UndefExpr (ArrayType n tp)) v is =+   insertValue (VecExpr tp $ Seq.replicate (fromIntegral n) (UndefExpr tp)) v is+insertValue (ZeroExpr (StructType si)) v is =+   insertValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, ZeroExpr tp)) tps) v is+ where tps = map fiType $ toList $ siFields si+insertValue (ZeroExpr (ArrayType n tp)) v is =+   insertValue (VecExpr tp $ Seq.replicate (fromIntegral n) (ZeroExpr tp)) v is+insertValue (StructExpr vs) v (i:is)+   | fromIntegral i < Seq.length vs = do+        let (xtp, x) = Seq.index vs (fromIntegral i)+        x' <- insertValue x v is+        return (StructExpr (Seq.adjust (\_ -> (xtp,x')) (fromIntegral i) vs))+insertValue (VecExpr tp vs) v (i:is)+   | fromIntegral i < Seq.length vs = do+        let x = Seq.index vs (fromIntegral i)+        x' <- insertValue x v is+        return (VecExpr tp (Seq.adjust (\_ -> x') (fromIntegral i) vs))+insertValue (BaseExpr (StructRepr ctx) x) v (i:is)+   | Just (Some idx) <- Ctx.intIndex (fromIntegral i) (Ctx.size ctx) = do+           let tpr = ctx Ctx.! idx+           x' <- insertValue (BaseExpr tpr (getStruct idx x)) v is+           let ?err = fail+           unpackOne x' $ \_px tpr' x'' ->+             case testEquality tpr tpr' of+               Just Refl -> return $ BaseExpr (StructRepr ctx) (setStruct ctx x idx x'')+               Nothing   -> fail "insertValue was expected to return base value of same type (struct case)"+insertValue (BaseExpr (VectorRepr elTp) x) v (i:is)+   | i >= 0 =+   do let n = fromIntegral i :: Natural+      x' <- insertValue (BaseExpr elTp (app (VectorGetEntry elTp x (litExpr n)))) v is+      let ?err = fail+      unpackOne x' $ \_px tpr' x'' ->+        case testEquality elTp tpr' of+          Just Refl -> return $ BaseExpr (VectorRepr elTp) (app (VectorSetEntry elTp x (litExpr n) x''))+          Nothing   -> fail "insertValue was expected to return base value of same type (vector case)"+insertValue _ _ _ = fail "invalid insertValue instruction"++++evalGEP :: forall s arch ret wptr.+  wptr ~ ArchWidth arch =>+  L.Instr ->+  GEPResult (LLVMExpr s arch) ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+evalGEP instr (GEPResult _lanes finalMemType gep0) = finish =<< go gep0+ where+ finish xs =+   case Seq.viewl xs of+     x Seq.:< (Seq.null -> True) -> return (BaseExpr PtrRepr x)+     _ -> return (VecExpr (PtrType (MemType finalMemType)) (fmap (BaseExpr PtrRepr) xs))++ badGEP :: LLVMGenerator s arch ret a+ badGEP = fail $ unlines ["Unexpected failure when evaluating GEP", showInstr instr]++ asPtr :: LLVMExpr s arch -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+ asPtr x =+   case asScalar x of+     Scalar _archProxy PtrRepr p -> return p+     _ -> badGEP++ go :: GEP n (LLVMExpr s arch) -> LLVMGenerator s arch ret (Seq (Expr LLVM s (LLVMPointerType wptr)))++ go (GEP_scalar_base x) =+      do p <- asPtr x+         return (Seq.singleton p)++ go (GEP_vector_base n x) =+      do xs <- maybe badGEP (traverse (\y -> asPtr y)) (asVector x)+         unless (fromIntegral (Seq.length xs) == natValue n) badGEP+         return xs++ go (GEP_scatter n gep) =+      do xs <- go gep+         unless (Seq.length xs == 1) badGEP+         return (Seq.cycleTaking (widthVal n) xs)++ go (GEP_field fi gep) =+      do xs <- go gep+         traverse (\x -> calcGEP_struct fi x) xs++ go (GEP_index_each mt' gep idx) =+      do xs <- go gep+         traverse (\x -> calcGEP_array mt' x idx) xs++ go (GEP_index_vector mt' gep idx) =+      do xs <- go gep+         idxs <- maybe badGEP return (asVector idx)+         unless (Seq.length idxs == Seq.length xs) badGEP+         traverse (\(x,i) -> calcGEP_array mt' x i) (Seq.zip xs idxs)+++calcGEP_array :: forall wptr s arch ret.+  wptr ~ ArchWidth arch =>+  MemType {- ^ Type of the array elements -} ->+  Expr LLVM s (LLVMPointerType wptr) {- ^ Base pointer -} ->+  LLVMExpr s arch {- ^ index value -} ->+  LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+calcGEP_array _typ base (ZeroExpr _) = return base+  -- If the array index is the concrete number 0, then return the base+  -- pointer unchanged.+calcGEP_array typ base idx =+  do -- sign-extend the index value if necessary to make it+     -- the same width as a pointer+     (idx' :: Expr LLVM s (BVType wptr))+       <- case asScalar idx of+              Scalar _archProxy (LLVMPointerRepr w) x+                 | Just Refl <- testEquality w PtrWidth ->+                      pointerAsBitvectorExpr PtrWidth x+                 | Just LeqProof <- testLeq (incNat w) PtrWidth ->+                   do x' <- pointerAsBitvectorExpr w x+                      return $ app (BVSext PtrWidth w x')+              _ -> fail $ unwords ["Invalid index value in GEP", show idx]++     -- Calculate the size of the element memtype and check that it fits+     -- in the pointer width+     let dl  = llvmDataLayout ?lc+     let isz = G.bytesToInteger $ memTypeSize dl typ+     unless (isz <= maxSigned PtrWidth)+       (fail $ unwords ["Type size too large for pointer width:", show typ])++     -- Perform the multiply+     mvar <- getMemVar+     off0 <- AtomExpr <$> (mkAtom $ app $ BVMul PtrWidth (app $ BVLit PtrWidth (BV.mkBV PtrWidth isz)) idx')+     let off  =+           if isz == 0+           then off0+           else+             let+               -- Compute safe upper and lower bounds for the index value to+               -- prevent multiplication overflow. Note that `minidx <= idx <=+               -- maxidx` iff `MININT <= (isz * idx) <= MAXINT` when `isz` and+               -- `idx` are considered as infinite precision integers. This+               -- property holds only if we use `quot` (which rounds toward 0)+               -- for the divisions in the following definitions.++               -- maximum and minimum indices to prevent multiplication overflow+               maxidx = maxSigned PtrWidth `quot` (max isz 1)+               minidx = minSigned PtrWidth `quot` (max isz 1)+               poison = Poison.GEPOutOfBounds base idx'+               cond   =+                (app $ BVSle PtrWidth (app $ BVLit PtrWidth (BV.mkBV PtrWidth minidx)) idx') .&&+                  (app $ BVSle PtrWidth idx' (app $ BVLit PtrWidth (BV.mkBV PtrWidth maxidx)))+             in+               -- Multiplication overflow will result in a pointer which is not "in+               -- bounds" for the given allocation. We translate all GEP+               -- instructions as if they had the `inbounds` flag set, so the+               -- result would be a poison value.+               poisonSideCondition mvar (BVRepr PtrWidth) poison off0 cond++     -- Perform the pointer offset arithmetic+     callPtrAddOffset base off+++calcGEP_struct ::+  wptr ~ ArchWidth arch =>+  FieldInfo ->+  Expr LLVM s (LLVMPointerType wptr) ->+  LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+calcGEP_struct fi base =+  do -- Get the field offset and check that it fits+     -- in the pointer width+     let ioff = G.bytesToInteger $ fiOffset fi+     unless (ioff <= maxSigned PtrWidth)+       (fail $ unwords ["Field offset too large for pointer width in structure:", show ioff])+     let off = app $ BVLit PtrWidth $ BV.mkBV PtrWidth ioff++     -- Perform the pointer arithmetic and continue+     -- Skip pointer arithmetic when offset is 0+     if ioff == 0 then return base else callPtrAddOffset base off+++translateConversion :: (?transOpts :: TranslationOptions) =>+  L.Instr ->+  L.ConvOp ->+  MemType {- Input type -} ->+  LLVMExpr s arch {- Value to convert -} ->+  MemType {- Output type -} ->+  LLVMGenerator s arch ret (LLVMExpr s arch)++-- Bitcast is a bit of a special case, handle separately+translateConversion _instr L.BitCast inty x outty = bitCast inty x outty++-- Perform translations pointwise on vectors+translateConversion instr op (VecType n inty) (explodeVector n -> Just xs) (VecType m outty)+  | n == m = VecExpr outty <$> traverse (\x -> translateConversion instr op inty x outty) xs++-- Otherwise, assume scalar values and do the basic conversions+translateConversion instr op _inty x outty =+ let showI = showInstr instr in+ case op of+    L.IntToPtr -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) _, LLVMPointerRepr w')+              | Just Refl <- testEquality w PtrWidth+              , Just Refl <- testEquality w' PtrWidth -> return x+           (Scalar _ t v, a)   ->+               fail (unlines ["integer-to-pointer conversion failed: "+                             , showI+                             , show v ++ " : " ++ show (pretty t) ++ " -to- " ++ show (pretty a)+                             ])+           (NotScalar, _) -> fail (unlines ["integer-to-pointer conversion failed: non scalar", showI])++    L.PtrToInt -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) _, LLVMPointerRepr w')+              | Just Refl <- testEquality w PtrWidth+              , Just Refl <- testEquality w' PtrWidth -> return x+           _ -> fail (unlines ["pointer-to-integer conversion failed", showI])++    L.Trunc -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w'))+             | Just LeqProof <- isPosNat w'+             , Just LeqProof <- testLeq (incNat w') w ->+                 do x_bv <- pointerAsBitvectorExpr w x'+                    let bv' = App (BVTrunc w' w x_bv)+                    return (BaseExpr outty' (BitvectorAsPointerExpr w' bv'))+           _ -> fail (unlines [unwords ["invalid truncation:", show x, show outty], showI])++    L.ZExt -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w'))+             | Just LeqProof <- isPosNat w+             , Just LeqProof <- testLeq (incNat w) w' ->+                 do x_bv <- pointerAsBitvectorExpr w x'+                    let bv' = App (BVZext w' w x_bv)+                    return (BaseExpr outty' (BitvectorAsPointerExpr w' bv'))+           _ -> fail (unlines [unwords ["invalid zero extension:", show x, show outty], showI])++    L.SExt -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w'))+             | Just LeqProof <- isPosNat w+             , Just LeqProof <- testLeq (incNat w) w' -> do+                 do x_bv <- pointerAsBitvectorExpr w x'+                    let bv' = App (BVSext w' w x_bv)+                    return (BaseExpr outty' (BitvectorAsPointerExpr w' bv'))+           _ -> fail (unlines [unwords ["invalid sign extension", show x, show outty], showI])++#if __GLASGOW_HASKELL__ < 900+    -- This is redundant, but GHC's pattern-match coverage checker is only+    -- smart enough to realize this in 9.0 or later.+    L.BitCast -> bitCast _inty x outty+#endif++    L.UiToFp -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) x', FloatRepr fi) -> do+             bv <- pointerAsBitvectorExpr w x'+             return $ BaseExpr (FloatRepr fi) $ App $ FloatFromBV fi RNE bv+           _ -> fail (unlines [unwords ["Invalid uitofp:", show op, show x, show outty], showI])++    L.SiToFp -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (LLVMPointerRepr w) x', FloatRepr fi) -> do+             bv <- pointerAsBitvectorExpr w x'+             return $ BaseExpr (FloatRepr fi) $ App $ FloatFromSBV fi RNE bv+           _ -> fail (unlines [unwords ["Invalid sitofp:", show op, show x, show outty], showI])++    L.FpToUi -> do+       let demoteToInt :: (1 <= w) => NatRepr w -> Expr LLVM s (FloatType fi) -> LLVMExpr s arch+           demoteToInt w v = BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w $ App $ FloatToBV w RNE v)+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (FloatRepr _) x', LLVMPointerRepr w) -> return $ demoteToInt w x'+           _ -> fail (unlines [unwords ["Invalid fptoui:", show op, show x, show outty], showI])++    L.FpToSi -> do+       let demoteToInt :: (1 <= w) => NatRepr w -> Expr LLVM s (FloatType fi) -> LLVMExpr s arch+           demoteToInt w v = BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w $ App $ FloatToSBV w RNE v)+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (FloatRepr _) x', LLVMPointerRepr w) -> return $ demoteToInt w x'+           _ -> fail (unlines [unwords ["Invalid fptosi:", show op, show x, show outty], showI])++    L.FpTrunc -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (FloatRepr _) x', FloatRepr fi) -> do+             return $ BaseExpr (FloatRepr fi) $ App $ FloatCast fi RNE x'+           _ -> fail (unlines [unwords ["Invalid fptrunc:", show op, show x, show outty], showI])++    L.FpExt -> do+       llvmTypeAsRepr outty $ \outty' ->+         case (asScalar x, outty') of+           (Scalar _archProxy (FloatRepr _) x', FloatRepr fi) -> do+             return $ BaseExpr (FloatRepr fi) $ App $ FloatCast fi RNE x'+           _ -> fail (unlines [unwords ["Invalid fpext:", show op, show x, show outty], showI])+++--------------------------------------------------------------------------------+-- Bit Cast+++bitCast :: (?lc::TypeContext,HasPtrWidth wptr, wptr ~ ArchWidth arch) =>+          MemType {- ^ starting type of the expression -} ->+          LLVMExpr s arch {- ^ expression to cast -} ->+          MemType {- ^ target type -} ->+          LLVMGenerator s arch ret (LLVMExpr s arch)++bitCast _ (ZeroExpr _) tgtT = return (ZeroExpr tgtT)++bitCast _ (UndefExpr _) tgtT = return (UndefExpr tgtT)++-- pointer casts always succeed+bitCast (PtrType _) expr (PtrType _) = return expr+bitCast (PtrType _) expr PtrOpaqueType = return expr+bitCast PtrOpaqueType expr (PtrType _) = return expr+bitCast PtrOpaqueType expr PtrOpaqueType = return expr++-- casts between vectors of the same length can just be done pointwise+bitCast (VecType n srcT) (explodeVector n -> Just xs) (VecType n' tgtT)+  | n == n' = VecExpr tgtT <$> traverse (\x -> bitCast srcT x tgtT) xs++-- otherwise, cast via an intermediate integer type of common width+bitCast srcT expr tgtT = mb =<< runMaybeT (+  case (memTypeBitwidth srcT, memTypeBitwidth tgtT) of+    (Just w1, Just w2) | w1 == w2 -> castToInt srcT expr >>= castFromInt tgtT w2+    _ -> mzero)++  where+  mb    = maybe (err [ "*** Invalid coercion of expression"+                     , indent (show expr)+                     , "of type"+                     , indent (show srcT)+                     , "to type"+                     , indent (show tgtT)+                     ]) return+  err msg = reportError $ fromString $ unlines ("[bitCast] Failed to perform cast:" : msg)+  indent msg = "  " ++ msg++castToInt :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) =>+  MemType {- ^ type of input expression -} ->+  LLVMExpr s arch ->+  MaybeT (LLVMGenerator' s arch ret) (LLVMExpr s arch)+castToInt (IntType w) (BaseExpr (LLVMPointerRepr wrepr) x)+  | w == natValue wrepr+  = lift (BaseExpr (BVRepr wrepr) <$> pointerAsBitvectorExpr wrepr x)++castToInt FloatType (BaseExpr (FloatRepr SingleFloatRepr) x)+  = return (BaseExpr (BVRepr (knownNat @32)) (app (FloatToBinary SingleFloatRepr x)))+castToInt DoubleType (BaseExpr (FloatRepr DoubleFloatRepr) x)+  = return (BaseExpr (BVRepr (knownNat @64)) (app (FloatToBinary DoubleFloatRepr x)))+castToInt X86_FP80Type (BaseExpr (FloatRepr X86_80FloatRepr) x)+  = return (BaseExpr (BVRepr (knownNat @80)) (app (FloatToBinary X86_80FloatRepr x)))++castToInt (VecType n tp) (explodeVector n -> Just xs) =+  do xs' <- traverse (castToInt tp) (toList xs)+     MaybeT (return (vecJoin xs'))+castToInt _ _ = mzero++castFromInt :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) =>+  MemType {- ^ target type -} ->+  Natural {- ^ bitvector width in bits -} ->+  LLVMExpr s arch -> MaybeT (LLVMGenerator' s arch ret) (LLVMExpr s arch)++castFromInt (IntType w1) w2 (BaseExpr (BVRepr w) x)+  | w1 == w2, w1 == natValue w+  = return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w x))++castFromInt FloatType 32 (BaseExpr (BVRepr w) x)+  | Just Refl <- testEquality w (knownNat @32)+  = return (BaseExpr (FloatRepr SingleFloatRepr) (app (FloatFromBinary SingleFloatRepr x)))++castFromInt DoubleType 64 (BaseExpr (BVRepr w) x)+  | Just Refl <- testEquality w (knownNat @64)+  = return (BaseExpr (FloatRepr DoubleFloatRepr) (app (FloatFromBinary DoubleFloatRepr x)))++castFromInt X86_FP80Type 80 (BaseExpr (BVRepr w) x)+  | Just Refl <- testEquality w (knownNat @80)+  = return (BaseExpr (FloatRepr X86_80FloatRepr) (app (FloatFromBinary X86_80FloatRepr x)))++castFromInt (VecType n tp) w expr+  | n > 0+  , (w',0) <- w `divMod` n+  , Some wrepr' <- mkNatRepr w'+  , Just LeqProof <- isPosNat wrepr'+  = do xs <- MaybeT (return (vecSplit wrepr' expr))+       VecExpr tp . Seq.fromList <$> traverse (castFromInt tp w') xs+castFromInt _ _ _ = mzero+++-- | Join the elements of a vector into a single bit-vector value.+-- The resulting bit-vector would be of length at least one.+vecJoin :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) =>+  [LLVMExpr s arch] {- ^ Join these vector elements -} ->+  Maybe (LLVMExpr s arch)+vecJoin exprs =+  do (a,ys) <- List.uncons exprs+     Scalar _archProxy (BVRepr (n :: NatRepr n)) e1 <- return (asScalar a)+     if null ys+       then do LeqProof <- testLeq (knownNat @1) n+               return (BaseExpr (BVRepr n) e1)+       else do BaseExpr (BVRepr m) e2 <- vecJoin ys+               let p1 = leqZero @n+                   p2 = leqProof (knownNat @1) m+               (LeqProof,LeqProof) <- return (leqAdd2 p1 p2, leqAdd2 p2 p1)+               let bits u v x y = bitVal (addNat u v) (BVConcat u v x y)+               return $! case llvmDataLayout ?lc ^. intLayout of+                           LittleEndian -> bits m n e2 e1+                           BigEndian    -> bits n m e1 e2+++bitVal ::+  (1 <= n) =>+  NatRepr n ->+  App LLVM (Expr LLVM s) (BVType n) ->+  LLVMExpr s arch+bitVal n e = BaseExpr (BVRepr n) (App e)+++-- | Split a single bit-vector value into a vector of value of the given width.+vecSplit :: forall s n w arch. (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch, 1 <= n) =>+  NatRepr n  {- ^ Length of a single element -} ->+  LLVMExpr s arch {- ^ Bit-vector value -} ->+  Maybe [ LLVMExpr s arch ]+vecSplit elLen expr =+  do Scalar _archProxy (BVRepr totLen) e <- return (asScalar expr)+     let getEl :: NatRepr offset -> Maybe [ LLVMExpr s arch ]+         getEl offset = let end = addNat offset elLen+                        in case testLeq end totLen of+                             Just LeqProof ->+                               do rest <- getEl end+                                  let x = bitVal elLen+                                            (BVSelect offset elLen totLen e)+                                  return (x : rest)+                             Nothing ->+                               do Refl <- testEquality offset totLen+                                  return []+     els <- getEl (knownNat @0)+     -- in `els` the least significant chunk is first++     return $! case lay ^. intLayout of+                 LittleEndian -> els+                 BigEndian    -> reverse els+  where+  lay = llvmDataLayout ?lc+++bitop :: (?transOpts :: TranslationOptions) =>+  L.BitOp ->+  MemType ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+bitop op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) =+  VecExpr tp <$> sequence (Seq.zipWith (\x y -> bitop op tp x y) xs ys)++bitop op _ x y =+  case (asScalar x, asScalar y) of+    (Scalar _archProxy (LLVMPointerRepr w) x',+     Scalar _archPrxy' (LLVMPointerRepr w') y')+      | Just Refl <- testEquality w w'+      , Just LeqProof <- isPosNat w -> do+         xbv <- pointerAsBitvectorExpr w x'+         ybv <- pointerAsBitvectorExpr w y'+         ex  <- raw_bitop op w xbv ybv+         return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w ex))++    _ -> fail $ unwords ["bitwise operation on unsupported values", show x, show y]++raw_bitop :: (?transOpts :: TranslationOptions, 1 <= w) =>+  L.BitOp ->+  NatRepr w ->+  Expr LLVM s (BVType w) ->+  Expr LLVM s (BVType w) ->+  LLVMGenerator s arch ret (Expr LLVM s (BVType w))+raw_bitop op w a b =+  do mvar <- getMemVar+     let withSideConds val lst = sideConditionsA mvar (BVRepr w) val lst+     let noLaxArith = not (laxArith ?transOpts)+     case op of+       L.And -> return $ App (BVAnd w a b)+       L.Or  -> return $ App (BVOr w a b)+       L.Xor -> return $ App (BVXor w a b)++       L.Shl nuw nsw -> do+         let wlit = App (BVLit w (BV.width w))+         result <- AtomExpr <$> mkAtom (App (BVShl w a b))+         withSideConds result+           [ ( noLaxArith+             , pure  $ App (BVUlt w b wlit) -- TODO: is this the right condition?+             , UB.PoisonValueCreated $ Poison.ShlOp2Big a b+             )+           , ( nuw && noLaxArith+             , fmap (App . BVEq w a . AtomExpr)+                    (mkAtom (App (BVLshr w result b)))+             , UB.PoisonValueCreated $ Poison.ShlNoUnsignedWrap a b+             )+           , ( nsw && noLaxArith+             , fmap (App . BVEq w a . AtomExpr)+                    (mkAtom (App (BVAshr w result b)))+             , UB.PoisonValueCreated $ Poison.ShlNoSignedWrap a b+             )+           ]++       L.Lshr exact -> do+         let wlit = App (BVLit w (BV.width w))+         result <- AtomExpr <$> mkAtom (App (BVLshr w a b))+         withSideConds result+           [ ( noLaxArith+             , pure  $ App (BVUlt w b wlit)+             , UB.PoisonValueCreated $ Poison.LshrOp2Big a b+             )+           , ( exact && noLaxArith+             , fmap (App . BVEq w a . AtomExpr)+                    (mkAtom (App (BVShl w result b)))+             , UB.PoisonValueCreated $ Poison.LshrExact a b+             )+           ]++       L.Ashr exact+         | Just LeqProof <- isPosNat w -> do+             let wlit = App (BVLit w (BV.width w))+             result <- AtomExpr <$> mkAtom (App (BVAshr w a b))+             withSideConds result+               [ ( noLaxArith+                 , pure  $ App (BVUlt w b wlit)+                 , UB.PoisonValueCreated $ Poison.AshrOp2Big a b+                 )+               , ( exact && noLaxArith+                 , fmap (App . BVEq w a)+                        (AtomExpr <$> mkAtom (App (BVShl w result b)))+                 , UB.PoisonValueCreated $ Poison.AshrExact a b+                 )+               ]++         | otherwise -> fail "cannot arithmetic right shift a 0-width integer"+++-- | Translate an LLVM integer operation into a Crucible CFG expression.+--+-- Poison values can arise from such operations.+intop :: forall w s arch ret. (?transOpts :: TranslationOptions, 1 <= w)+      => L.ArithOp+      -> NatRepr w+      -> Expr LLVM s (BVType w)+      -> Expr LLVM s (BVType w)+      -> LLVMGenerator s arch ret (Expr LLVM s (BVType w))+intop op w a b =+  do mvar <- getMemVar+     let withSideConds val lst = sideConditionsA mvar (BVRepr w) val lst+     let withPoison val xs =+           do v <- AtomExpr <$> mkAtom val+              withSideConds v $ map (\(d, e, c) -> (d, pure e, UB.PoisonValueCreated c)) xs+     let z        = App (BVLit w (BV.zero w))+     let bNeqZero = \ub -> (True, pure (notExpr (App (BVEq w z b))), ub)+     let neg1     = App (BVLit w (BV.mkBV w (-1)))+     let minInt   = App (BVLit w (BV.minSigned w))+     let noLaxArith = not (laxArith ?transOpts)+     case op of+       L.Add nuw nsw -> withPoison (App (BVAdd w a b))+         [ ( nuw && noLaxArith+           , notExpr (App (BVCarry w a b))+           , Poison.AddNoUnsignedWrap a b+           )+         , ( nsw && noLaxArith+           , notExpr (App (BVSCarry w a b))+           , Poison.AddNoSignedWrap a b+           )+         ]++       L.Sub nuw nsw -> withPoison (App (BVSub w a b))+         [ ( nuw && noLaxArith+           , notExpr (App (BVUlt w a b))+           , Poison.SubNoUnsignedWrap a b+           )+         , ( nsw && noLaxArith+           , notExpr (App (BVSBorrow w a b))+           , Poison.SubNoSignedWrap a b+           )+         ]++       L.Mul nuw nsw -> do+         let w' = addNat w w+         Just LeqProof <- return $ isPosNat w'+         Just LeqProof <- return $ testLeq (incNat w) w'++         prod <- AtomExpr <$> mkAtom (App (BVMul w a b))+         withSideConds prod+           [ ( nuw && noLaxArith+             , do+                 az       <- AtomExpr <$> mkAtom (App (BVZext w' w a))+                 bz       <- AtomExpr <$> mkAtom (App (BVZext w' w b))+                 wideprod <- AtomExpr <$> mkAtom (App (BVMul w' az bz))+                 prodz    <- AtomExpr <$> mkAtom (App (BVZext w' w prod))+                 return (App (BVEq w' wideprod prodz))+             , UB.PoisonValueCreated $ Poison.MulNoUnsignedWrap a b+             )+           , ( nsw && noLaxArith+             , do+                 as       <- AtomExpr <$> mkAtom (App (BVSext w' w a))+                 bs       <- AtomExpr <$> mkAtom (App (BVSext w' w b))+                 wideprod <- AtomExpr <$> mkAtom (App (BVMul w' as bs))+                 prods    <- AtomExpr <$> mkAtom (App (BVSext w' w prod))+                 return (App (BVEq w' wideprod prods))+             , UB.PoisonValueCreated $ Poison.MulNoSignedWrap a b+             )+           ]++       L.UDiv exact -> do+         q <- AtomExpr <$> mkAtom (App (BVUdiv w a b))+         withSideConds q+           [ ( exact && noLaxArith+             , fmap (App . BVEq w a . AtomExpr)+                    (mkAtom (App (BVMul w q b)))+             , UB.PoisonValueCreated $ Poison.UDivExact a b+             )+           , bNeqZero (UB.UDivByZero a b)+           ]++       L.SDiv exact+         | Just LeqProof <- isPosNat w -> do+           q <- AtomExpr <$> mkAtom (App (BVSdiv w a b))+           withSideConds q+            [ ( exact && noLaxArith+              , fmap (App . BVEq w a . AtomExpr)+                     (mkAtom (App (BVMul w q b)))+              , UB.PoisonValueCreated $ Poison.SDivExact a b+              )+            , ( noLaxArith+              , pure (notExpr (App (BVEq w neg1 b) .&& App (BVEq w minInt a)))+              , UB.SDivOverflow a b+              )+            , bNeqZero (UB.SDivByZero a b)+            ]++         | otherwise -> fail "cannot take the signed quotient of a 0-width bitvector"++       L.URem -> withSideConds (App (BVUrem w a b)) [ bNeqZero (UB.URemByZero a b) ]++       L.SRem+         | Just LeqProof <- isPosNat w ->+            do r <- AtomExpr <$> mkAtom (App (BVSrem w a b))+               withSideConds r+                 [ ( noLaxArith+                   , pure (notExpr (App (BVEq w neg1 b) .&& App (BVEq w minInt a)))+                   , UB.SRemOverflow a b+                   )+                 , bNeqZero (UB.SRemByZero a b)+                 ]++         | otherwise -> fail "cannot take the signed remainder of a 0-width bitvector"++       _ -> fail $ unwords ["unsupported integer arith operation", show op]++caseptr+  :: (1 <= w)+  => NatRepr w+  -> TypeRepr a+  -> (Expr LLVM s (BVType w) ->+      LLVMGenerator s arch ret (Expr LLVM s a))+  -> (Expr LLVM s NatType -> Expr LLVM s (BVType w) ->+      LLVMGenerator s arch ret (Expr LLVM s a))+  -> Expr LLVM s (LLVMPointerType w)+  -> LLVMGenerator s arch ret (Expr LLVM s a)++caseptr w tpr bvCase ptrCase x =+  case x of+    PointerExpr _ blk off ->+      case asApp blk of+        Just (NatLit 0) -> bvCase off+        Just (NatLit _) -> ptrCase blk off+        _               -> ptrSwitch blk off++    _ -> do a_x <- forceEvaluation x+            blk <- forceEvaluation (App (ExtensionApp (LLVM_PointerBlock w a_x)))+            off <- forceEvaluation (App (ExtensionApp (LLVM_PointerOffset w a_x)))+            ptrSwitch blk off+  where+  ptrSwitch blk off =+    do let cond = (blk .== litExpr 0)+       c_label  <- newLambdaLabel' tpr+       bv_label <- defineBlockLabel (bvCase off >>= jumpToLambda c_label)+       ptr_label <- defineBlockLabel (ptrCase blk off >>= jumpToLambda c_label)+       continueLambda c_label (branch cond bv_label ptr_label)++atomicRWOp ::+  L.AtomicRWOp ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+atomicRWOp op x y =+  case (asScalar x, asScalar y) of+    (Scalar _archProxy (LLVMPointerRepr (w :: NatRepr w)) x', Scalar _archProxy' (LLVMPointerRepr w') y')+      | Just Refl <- testEquality w w'+      -> do xbv <- pointerAsBitvectorExpr w x'+            ybv <- pointerAsBitvectorExpr w y'+            let newval = case op of+                   L.AtomicXchg -> ybv+                   L.AtomicAdd  -> app $ BVAdd w xbv ybv+                   L.AtomicSub  -> app $ BVSub w xbv ybv+                   L.AtomicAnd  -> app $ BVAnd w xbv ybv+                   L.AtomicNand -> app $ BVNot w $ app $ BVAnd w xbv ybv+                   L.AtomicOr   -> app $ BVOr w xbv ybv+                   L.AtomicXor  -> app $ BVXor w xbv ybv+                   L.AtomicMax  -> app $ BVSMax w xbv ybv+                   L.AtomicMin  -> app $ BVSMin w xbv ybv+                   L.AtomicUMax -> app $ BVUMax w xbv ybv+                   L.AtomicUMin -> app $ BVUMin w xbv ybv+            return $ BaseExpr (LLVMPointerRepr w) $ BitvectorAsPointerExpr w newval++    _ -> fail $ unlines [ "atomicRW operation on incompatible values"+                        , "Operation: " ++ show op+                        , "Value 1: " ++ show x+                        , "Value 2: " ++ show y+                        ]++floatingCompare ::+  L.FCmpOp ->+  MemType ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+floatingCompare op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) =+  VecExpr (IntType 1) <$> sequence (Seq.zipWith (\x y -> floatingCompare op tp x y) xs ys)++floatingCompare op _ x y =+  do b <- scalarFloatingCompare op x y+     return (BaseExpr (LLVMPointerRepr (knownNat :: NatRepr 1))+                      (BitvectorAsPointerExpr knownNat (App (BoolToBV knownNat b))))++scalarFloatingCompare ::+  L.FCmpOp ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (Expr LLVM s BoolType)+scalarFloatingCompare op x y =+  case (asScalar x, asScalar y) of+     (Scalar _archProxy (FloatRepr fi) x',+      Scalar _archPrxy' (FloatRepr fi') y')+      | Just Refl <- testEquality fi fi' ->+          return (floatcmp op x' y')++     _ -> fail $ unwords ["Floating point comparison on incompatible values", show x, show y]++floatcmp ::+  L.FCmpOp ->+  Expr LLVM s (FloatType fi) ->+  Expr LLVM s (FloatType fi) ->+  Expr LLVM s BoolType+floatcmp op a b =+   let isNaNCond = App . FloatIsNaN+       -- True if a is NAN or b is NAN+       unoCond = App $ Or (isNaNCond a) (isNaNCond b)+       mkUno c = App $ Or c unoCond+    in case op of+          L.Ftrue  -> App $ BoolLit True+          L.Ffalse -> App $ BoolLit False+          L.Foeq   -> App $ FloatFpEq a b+          L.Folt   -> App $ FloatLt a b+          L.Fole   -> App $ FloatLe a b+          L.Fogt   -> App $ FloatGt a b+          L.Foge   -> App $ FloatGe a b+          L.Fone   -> App $ FloatFpApart a b+          L.Fueq   -> mkUno $ App $ FloatFpEq a b+          L.Fult   -> mkUno $ App $ FloatLt a b+          L.Fule   -> mkUno $ App $ FloatLe a b+          L.Fugt   -> mkUno $ App $ FloatGt a b+          L.Fuge   -> mkUno $ App $ FloatGe a b+          L.Fune   -> mkUno $ App $ FloatFpApart a b+          L.Ford   -> App $ And (App $ Not $ isNaNCond a) (App $ Not $ isNaNCond b)+          L.Funo   -> unoCond+++integerCompare ::+  L.ICmpOp ->+  MemType ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+integerCompare op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) =+  VecExpr (IntType 1) <$> sequence (Seq.zipWith (\x y -> integerCompare op tp x y) xs ys)++integerCompare op _ x y = do+  b <- scalarIntegerCompare op x y+  return (BaseExpr (LLVMPointerRepr (knownNat :: NatRepr 1))+                   (BitvectorAsPointerExpr knownNat (App (BoolToBV knownNat b))))++scalarIntegerCompare ::+  L.ICmpOp ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (Expr LLVM s BoolType)+scalarIntegerCompare op x y =+  case (asScalar x, asScalar y) of+    (Scalar _archProxy (LLVMPointerRepr w) x'', Scalar _archProxy' (LLVMPointerRepr w') y'')+       | Just Refl <- testEquality w w'+       , Just Refl <- testEquality w PtrWidth+       -> pointerCmp op x'' y''+       | Just Refl <- testEquality w w'+       -> do xbv <- pointerAsBitvectorExpr w x''+             ybv <- pointerAsBitvectorExpr w y''+             return (intcmp w op xbv ybv)+    _ -> fail $ unlines [ "arithmetic comparison on incompatible values"+                        , "Comparison: " ++ show op+                        , "Value 1: " ++ show x+                        , "Value 2: " ++ show y+                        ]++intcmp :: (1 <= w)+    => NatRepr w+    -> L.ICmpOp+    -> Expr LLVM s (BVType w)+    -> Expr LLVM s (BVType w)+    -> Expr LLVM s BoolType+intcmp w op a b =+   case op of+      L.Ieq  -> App (BVEq w a b)+      L.Ine  -> App (Not (App (BVEq w a b)))+      L.Iult -> App (BVUlt w a b)+      L.Iule -> App (BVUle w a b)+      L.Iugt -> App (BVUlt w b a)+      L.Iuge -> App (BVUle w b a)+      L.Islt -> App (BVSlt w a b)+      L.Isle -> App (BVSle w a b)+      L.Isgt -> App (BVSlt w b a)+      L.Isge -> App (BVSle w b a)++pointerCmp+   :: (wptr ~ ArchWidth arch)+   => L.ICmpOp+   -> Expr LLVM s (LLVMPointerType wptr)+   -> Expr LLVM s (LLVMPointerType wptr)+   -> LLVMGenerator s arch ret (Expr LLVM s BoolType)+pointerCmp op x y =+  caseptr PtrWidth knownRepr+    (\x_bv ->+      caseptr PtrWidth knownRepr+        (\y_bv   -> return $ intcmp PtrWidth op x_bv y_bv)+        (\_ _ -> ptr_bv_compare x_bv y)+        y)+    (\_ _ ->+      caseptr PtrWidth knownRepr+        (\y_bv   -> ptr_bv_compare y_bv x)+        (\_ _    -> ptrOp)+        y)+    x+ where++  -- Special case: a pointer can be compared for equality with an integer, as long as+  -- that integer is 0, representing the null pointer.+  ptr_bv_compare bv ptr = do+    -- TODO: We can't use assertUndefinedSym here since the type variable 'sym'+    -- isn't in scope. How should this be fixed?+    assertExpr+      (App (BVEq PtrWidth bv (App (BVLit PtrWidth (BV.zero PtrWidth)))))+      (litExpr "Undefined comparison between pointer and integer")+    case op of+      L.Ieq  -> callIsNull PtrWidth ptr+      L.Ine  -> App . Not <$> callIsNull PtrWidth ptr+      _ -> reportError $ litExpr $ Text.pack $ unlines $+            [ "Arithmetic comparison on incompatible values"+            , "Comparison operation: " ++ show op+            , "Value 1: " ++ show x+            , "Value 2: " ++ show y+            ]++  ptrOp =+    do memVar <- getMemVar+       case op of+         L.Ieq -> do+           isEq <- extensionStmt (LLVM_PtrEq memVar x y)+           return $ isEq+         L.Ine -> do+           isEq <- extensionStmt (LLVM_PtrEq memVar x y)+           return $ App (Not isEq)+         L.Iule -> do+           isLe <- extensionStmt (LLVM_PtrLe memVar x y)+           return $ isLe+         L.Iult -> do+           isGe <- extensionStmt (LLVM_PtrLe memVar y x)+           return $ App (Not isGe)+         L.Iuge -> do+           isGe <- extensionStmt (LLVM_PtrLe memVar y x)+           return $ isGe+         L.Iugt -> do+           isLe <- extensionStmt (LLVM_PtrLe memVar x y)+           return $ App (Not isLe)+         _ -> reportError $ litExpr $ Text.pack $ unlines $+                [ "Signed comparison on pointer values"+                , "Comparison operation: " ++ show op+                , "Value 1:" ++ show x+                , "Value 2" ++ show y+                ]++pointerOp+   :: (wptr ~ ArchWidth arch, ?transOpts :: TranslationOptions)+   => L.ArithOp+   -> Expr LLVM s (LLVMPointerType wptr)+   -> Expr LLVM s (LLVMPointerType wptr)+   -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr))+pointerOp op x y =+  caseptr PtrWidth PtrRepr+    (\x_bv  ->+      caseptr PtrWidth PtrRepr+        (\y_bv  -> BitvectorAsPointerExpr PtrWidth <$>+                     intop op PtrWidth x_bv y_bv)+        (\_ _   -> bv_ptr_op x_bv)+        y)+    (\_ _ ->+      caseptr PtrWidth PtrRepr+        (\y_bv  -> ptr_bv_op y_bv)+        (\_ _   -> ptr_ptr_op)+      y)+    x+ where+  ptr_bv_op y_bv =+    case op of+      L.Add _ _ ->+           callPtrAddOffset x y_bv+      L.Sub _ _ ->+        do let off = App (BVSub PtrWidth (App $ BVLit PtrWidth (BV.zero PtrWidth)) y_bv)+           callPtrAddOffset x off+      _ -> err++  bv_ptr_op x_bv =+    case op of+      L.Add _ _ -> callPtrAddOffset y x_bv+      _ -> err++  ptr_ptr_op =+    case op of+      L.Sub _ _ -> BitvectorAsPointerExpr PtrWidth <$> callPtrSubtract x y+      _ -> err++  err = reportError $ litExpr $ Text.pack $ unlines $+          [ "Invalid pointer operation"+          , "Operation: " ++ show op+          , "Value 1: " ++ show x+          , "Value 2: " ++ show y+          ]+++baseSelect ::+   (?lc :: TypeContext, HasPtrWidth wptr, wptr ~ ArchWidth arch) =>+   LLVMExpr s arch {- ^ Selection expression -} ->+   LLVMExpr s arch {- ^ true expression -} ->+   LLVMExpr s arch {- ^ false expression -} ->+   LLVMGenerator s arch ret (Maybe (LLVMExpr s arch))+baseSelect (asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c) (asScalar -> Scalar _ xtp x) (asScalar -> Scalar _ ytp y)+  | Just Refl <- testEquality xtp ytp+  , LLVMPointerRepr w <- xtp+  = do c' <- callIntToBool wc c+       z <- forceEvaluation (App (ExtensionApp (LLVM_PointerIte w c' x y)))+       return (Just (BaseExpr (LLVMPointerRepr w) z))++baseSelect (asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c) (asScalar -> Scalar _ xtp x) (asScalar -> Scalar _ ytp y)+  | Just Refl <- testEquality xtp ytp+  , AsBaseType btp <- asBaseType xtp+  = do c' <- callIntToBool wc c+       z <- forceEvaluation (app (BaseIte btp c' x y))+       return (Just (BaseExpr xtp z))++baseSelect _ _ _ = return Nothing+++translateSelect ::+   (?lc :: TypeContext, HasPtrWidth wptr, wptr ~ ArchWidth arch) =>+   L.Instr        {- ^ The instruction to translate -} ->+   (LLVMExpr s arch -> LLVMGenerator s arch ret ())+     {- ^ A continuation to assign the produced value of this instruction to a register -} ->+   MemType {- ^ Type of the selector variable -} ->+   LLVMExpr s arch {- ^ Selection expression -} ->+   MemType {- ^ Type of the select branches -} ->+   LLVMExpr s arch {- ^ true expression -} ->+   LLVMExpr s arch {- ^ false expression -} ->+   LLVMGenerator s arch ret ()+translateSelect instr assign_f+                  (VecType n _) (explodeVector n -> Just cs)+                  (VecType m eltp) (explodeVector n -> Just xs) (explodeVector n -> Just ys)+  | n == m+  = do zs <- forM [0..n-1] $ \i ->+               do Just c <- return $ Seq.lookup (fromIntegral i) cs+                  Just x <- return $ Seq.lookup (fromIntegral i) xs+                  Just y <- return $ Seq.lookup (fromIntegral i) ys+                  mz <- baseSelect c x y+                  maybe (fail $ unlines ["invalid select operation", showInstr instr]) return mz++       assign_f (VecExpr eltp (Seq.fromList zs))++translateSelect instr assign_f+                  _ctp c+                  (VecType n eltp) (explodeVector n -> Just xs) (explodeVector n -> Just ys)+  = do zs <- forM [0..n-1] $ \i ->+               do Just x <- return $ Seq.lookup (fromIntegral i) xs+                  Just y <- return $ Seq.lookup (fromIntegral i) ys+                  mz <- baseSelect c x y+                  maybe (fail $ unlines ["invalid select operation", showInstr instr]) return mz++       assign_f (VecExpr eltp (Seq.fromList zs))++translateSelect _ assign_f _ctp c@(asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c') _tp x y+  = do mz <- baseSelect c x y+       case mz of+         Just z -> assign_f z+         Nothing ->+           do c'' <- callIntToBool wc c'+              ifte_ c'' (assign_f x) (assign_f y)++translateSelect instr _ _ _ _ _ _ =+   fail $ unlines ["invalid select operation", showInstr instr]+++-- | Do the heavy lifting of translating LLVM instructions to crucible code.+generateInstr :: forall s arch ret a.+   (?transOpts :: TranslationOptions) =>+   TypeRepr ret   {- ^ Type of the function return value -} ->+   L.BlockLabel   {- ^ The label of the current LLVM basic block -} ->+   Set L.Ident {- ^ Set of usable identifiers -} ->+   L.Instr        {- ^ The instruction to translate -} ->+   (LLVMExpr s arch -> LLVMGenerator s arch ret ())+     {- ^ A continuation to assign the produced value of this instruction to a register -} ->+   LLVMGenerator s arch ret a+     {- ^ A continuation for translating the remaining statements in this function.+          Straightline instructions should enter this continuation,+          but block-terminating instructions should not. -} ->+   LLVMGenerator s arch ret a+generateInstr retType lab defSet instr assign_f k =+  case instr of+    -- skip phi instructions, they are handled in definePhiBlock+    L.Phi _ _ -> k+    L.Comment _ -> k+    L.Unreachable -> reportError "LLVM unreachable code"++    L.ExtractValue x is -> do+        x' <- transTypedValue x+        v <- extractValue x' is+        assign_f v+        k++    L.InsertValue x v is -> do+        x' <- transTypedValue x+        v' <- transTypedValue v+        y <- insertValue x' v' is+        assign_f y+        k++    L.ExtractElt x i ->+        case x of+          L.Typed (L.Vector n ty) x' -> do+            ty' <- liftMemType' ty+            x'' <- transValue (VecType (fromIntegral n) ty') x'+            i'  <- transValue (IntType 64) i               -- FIXME? this is a bit of a hack, since the llvm-pretty+                                                           -- AST doesn't track the size of the index value+            y <- extractElt instr ty' (fromIntegral n) x'' i'+            assign_f y+            k++          _ -> fail $ unwords ["expected vector type in extractelement instruction:", show x]++    L.InsertElt x v i ->+        case x of+          L.Typed (L.Vector n ty) x' -> do+            ty' <- liftMemType' ty+            x'' <- transValue (VecType (fromIntegral n) ty') x'+            v'  <- transTypedValue v+            i'  <- transValue (IntType 64) i                -- FIXME? this is a bit of a hack, since the llvm-pretty+                                                            -- AST doesn't track the size of the index value+            y <- insertElt instr ty' (fromIntegral n) x'' v' i'+            assign_f y+            k++          _ -> fail $ unwords ["expected vector type in insertelement instruction:", show x]++    L.ShuffleVector sV1 sV2 sIxes ->+      case (L.typedType sV1, L.typedType sIxes) of+        (L.Vector m ty, L.Vector n (L.PrimType (L.Integer 32))) ->+          do elTy <- liftMemType' ty+             let inL :: Num b => b+                 inL  = fromIntegral m++                 inV  = VecType inL elTy++                 outL :: Num b => b+                 outL = fromIntegral n++             xv1 <- transValue inV (L.typedValue sV1)+             xv2 <- transValue inV sV2+             xis <- transValue (VecType outL (IntType 32)) (L.typedValue sIxes)++             case (explodeVector inL xv1, explodeVector inL xv2, explodeVector outL xis) of+               (Just v1, Just v2, Just is) ->+                 do let getV x =+                          case x of+                            UndefExpr _ -> return $ UndefExpr elTy+                            ZeroExpr _  -> return $ Seq.index v1 0+                            BaseExpr (LLVMPointerRepr _) (BitvectorAsPointerExpr _ (App (BVLit _ i)))+                              | BV.asUnsigned i < inL -> return $ Seq.index v1 (fromIntegral (BV.asUnsigned i))+                              | inL <= BV.asUnsigned i && BV.asUnsigned i < 2*inL ->+                                  return $ Seq.index v2 (fromIntegral (BV.asUnsigned i - inL))++                            _ -> fail $ unwords ["[shuffle] Expected literal index values but got", show x]++                    is' <- traverse getV is+                    assign_f (VecExpr elTy is')+                    k++               _ -> fail $ unlines ["[shuffle] unexpected values:"+                                   , showInstr instr+                                   , show xv1, show xv2, show xis]++        (t1,t2) -> fail $ unlines ["[shuffle] Type error", show t1, show t2 ]+++    L.Alloca tp num align -> do+      tp' <- liftMemType' tp+      let dl = llvmDataLayout ?lc+      let tp_sz = memTypeSize dl tp'+      let tp_sz' = app $ BVLit PtrWidth $ G.bytesToBV PtrWidth tp_sz++      sz <- case num of+               Nothing -> return $ tp_sz'+               Just num' -> do+                  n <- transTypedValue num'+                  case n of+                     ZeroExpr _ -> return $ app $ BVLit PtrWidth (BV.zero PtrWidth)+                     BaseExpr (LLVMPointerRepr w) x+                        | Just Refl <- testEquality w PtrWidth ->+                            do x' <- pointerAsBitvectorExpr w x+                               return $ app $ BVMul PtrWidth x' tp_sz'+                     _ -> fail $ "Invalid alloca argument: " ++ show num++      -- LLVM documentation regarding `alloca` alignment:+      --+      -- If a constant alignment is specified, the value result of the+      -- allocation is guaranteed to be aligned to at least that+      -- boundary. The alignment may not be greater than 1 << 29. If+      -- not specified, or if zero, the target can choose to align the+      -- allocation on any convenient boundary compatible with the+      -- type.+      alignment <-+       case align of+         Just a | a > 0 ->+           case toAlignment (G.toBytes a) of+             Nothing -> fail $ "Invalid alignment value in alloca: " ++ show a+             Just al -> return al+         _ -> return (memTypeAlign dl tp')++      p <- callAlloca sz alignment+      assign_f (BaseExpr (LLVMPointerRepr PtrWidth) p)+      k++    -- We don't care if it's atomic, since the symbolic simulator is+    -- effectively single-threaded.+    L.Load tp ptr _atomic align -> do+      resTy <- liftMemType' tp+      ptr' <- transTypedValue ptr+      llvmTypeAsRepr resTy $ \expectTy -> do+        let a0 = memTypeAlign (llvmDataLayout ?lc) resTy+        let align' = fromMaybe a0 (toAlignment . G.toBytes =<< align)+        res <- callLoad resTy expectTy ptr' align'+        assign_f res+        k++    -- We don't care if it's atomic, since the symbolic simulator is+    -- effectively single-threaded.+    L.Store v ptr _atomic align -> do+      vTp <- liftMemType' (L.typedType v)+      ptr' <- transTypedValue ptr+      let a0 = memTypeAlign (llvmDataLayout ?lc) vTp+      let align' = fromMaybe a0 (toAlignment . G.toBytes =<< align)+      v' <- transValue vTp (L.typedValue v)+      callStore vTp ptr' v' align'+      k++    -- NB We treat every GEP as though it has the "inbounds" flag set;+    --    thus, the calculation of out-of-bounds pointers results in+    --    a runtime error.+    L.GEP inbounds baseTy basePtr elts -> do+      runExceptT (translateGEP inbounds baseTy basePtr elts) >>= \case+        Left err -> reportError $ fromString $ unlines ["Error translating GEP", err]+        Right gep ->+          do gep' <- traverse (\v -> transTypedValue v) gep+             v    <- evalGEP instr gep'+             assign_f v+             k++    L.Conv op x outty -> do+      do tp <- liftMemType' (L.typedType x)+         x' <- transValue tp (L.typedValue x)+         outty' <- liftMemType' outty+         v <- translateConversion instr op tp x' outty'+         assign_f v+         k++    L.Call tailcall fnTy fn args ->+      callFunction defSet instr tailcall fnTy fn args assign_f >> k++    L.Invoke fnTy fn args normLabel _unwindLabel -> do+      do callFunction defSet instr False fnTy fn args assign_f+         definePhiBlock lab normLabel++    L.CallBr fnTy fn args normLabel otherLabels -> do+      do callFunction defSet instr False fnTy fn args assign_f+         for_ otherLabels $ \lab' -> void (definePhiBlock lab lab')+         definePhiBlock lab normLabel++    L.Bit op x y ->+      do tp <- liftMemType' (L.typedType x)+         x' <- transValue tp (L.typedValue x)+         y' <- transValue tp y+         v  <- bitop op tp x' y'+         assign_f v+         k++    L.Arith op x y ->+      do tp <- liftMemType' (L.typedType x)+         x' <- transValue tp (L.typedValue x)+         y' <- transValue tp y+         v  <- arithOp op tp x' y'+         assign_f v+         k++    L.UnaryArith op x ->+      do tp <- liftMemType' (L.typedType x)+         x' <- transValue tp (L.typedValue x)+         v  <- unaryArithOp op tp x'+         assign_f v+         k++    L.FCmp op x y -> do+           tp <- liftMemType' (L.typedType x)+           x' <- transValue tp (L.typedValue x)+           y' <- transValue tp y+           cmp <- floatingCompare op tp x' y'+           assign_f cmp+           k++    L.ICmp op x y -> do+           tp <- liftMemType' (L.typedType x)+           x' <- transTypedValue x+           y' <- transTypedValue (L.Typed (L.typedType x) y)+           cmp <- integerCompare op tp x' y'+           assign_f cmp+           k++    L.Select c x y -> do+         ctp <- liftMemType' (L.typedType c)+         c'  <- transValue ctp (L.typedValue c)++         tp  <- liftMemType' (L.typedType x)+         x'  <- transValue tp (L.typedValue x)+         y'  <- transValue tp y++         translateSelect instr assign_f ctp c' tp x' y'+         k++    L.Jump l' -> definePhiBlock lab l'++    L.Br v l1 l2 -> do+        v' <- transTypedValue v+        e' <- case asScalar v' of+                 Scalar _archProxy (LLVMPointerRepr w) e -> callIntToBool w e+                 _ -> fail "expected boolean condition on branch"++        phi1 <- defineBlockLabel (definePhiBlock lab l1)+        phi2 <- defineBlockLabel (definePhiBlock lab l2)+        branch e' phi1 phi2++    L.Switch x def branches -> do+        x' <- transTypedValue x+        case asScalar x' of+          Scalar _archProxy (LLVMPointerRepr w) x'' ->+            do bv <- pointerAsBitvectorExpr w x''+               buildSwitch w bv lab def branches+          _ -> fail $ unwords ["expected integer value in switch", showInstr instr]++    L.Ret v -> do v' <- transTypedValue v+                  let ?err = fail+                  unpackOne v' $ \_archProxy retType' ex ->+                     case testEquality retType retType' of+                        Just Refl -> do+                           callPopFrame+                           returnFromFunction ex+                        Nothing -> fail $ unwords ["unexpected return type", show retType, show retType']++    L.RetVoid -> case testEquality retType UnitRepr of+                    Just Refl -> do+                       callPopFrame+                       returnFromFunction (App EmptyApp)+                    Nothing -> fail $ unwords ["tried to void return from non-void function", show retType]++    -- NB, the symbolic simulator is essentially single-threaded, so fence+    -- instructions are no-ops+    L.Fence{} -> k++    -- NB, the symbolic simulator is essentially single-threaded, so cmpxchg+    -- always succeeds if the expected value is found in memory.+    L.CmpXchg _weak _volatile ptr compareValue newValue _syncScope _syncOrderSuccess _syncOrderFail ->+      do resTy <- liftMemType' (L.typedType compareValue)+         ptr' <- transTypedValue ptr+         llvmTypeAsRepr resTy $ \expectTy ->+           do cmpVal <- transValue resTy (L.typedValue compareValue)+              newVal <- transValue resTy (L.typedValue newValue)++              let a0 = memTypeAlign (llvmDataLayout ?lc) resTy+              oldVal <- callLoad resTy expectTy ptr' a0+              cmp <- scalarIntegerCompare L.Ieq oldVal cmpVal+              let flag = BaseExpr (LLVMPointerRepr (knownNat @1))+                                  (BitvectorAsPointerExpr knownNat+                                     (App (BoolToBV knownNat cmp)))+              ifte_ cmp+                -- success case, write the new value+                (callStore resTy ptr' newVal a0)+                -- failure case, do nothing+                (return ())+              assign_f (StructExpr (Seq.fromList [(resTy,oldVal),(IntType 1,flag)]))+              k++    -- NB, the symbolic simulator is essentially single-threaded, so no special+    -- actions need to be taken to make operations atomic.  We simply execute+    -- their straightforward load/modify/store semantics.+    L.AtomicRW _volatile op ptr val _syncScope _ordering ->+      do valTy <- liftMemType' (L.typedType val)+         ptr' <- transTypedValue ptr+         case valTy of+           IntType _ -> pure ()+           _ -> fail $ unwords+             ["Invalid argument type on atomicrw, expected integer type", show ptr]+         llvmTypeAsRepr valTy $ \expectTy ->+           do val' <- transValue valTy $ L.typedValue val+              let a0 = memTypeAlign (llvmDataLayout ?lc) valTy+              oldVal <- callLoad valTy expectTy ptr' a0+              newVal <- atomicRWOp op oldVal val'+              callStore valTy ptr' newVal a0+              assign_f oldVal+              k++    -- We translate `freeze` instructions by simply passing the argument value+    -- through unchanged. This doesn't quite adhere to LLVM's own semantics for+    -- this instruction (https://releases.llvm.org/12.0.0/docs/LangRef.html#id323),+    -- which state that if the argument is `undef` or `poison`, then `freeze`+    -- should return an arbitrary value. We don't currently have the ability to+    -- reliably determine whether a given value is `undef` or `poison`, however+    -- (see https://github.com/GaloisInc/crucible/issues/366), so for now we+    -- settle for a less accurate translation of `freeze`.+    L.Freeze x -> do+      tp' <- liftMemType' (L.typedType x)+      x'  <- transValue tp' (L.typedValue x)+      assign_f x'+      k++    -- unwind, landingpad and resume are all exception-related, which we don't currently+    -- support+    L.Unwind{} -> unsupported+    L.LandingPad{} -> unsupported+    L.Resume{} -> unsupported++    -- indirect branch could be supported, but requires some nontrivial work to deal+    -- properly with mapping basic-block labels to pointer values.+    L.IndirectBr{} -> unsupported++    -- VaArg is uncommonly used and hard to support+    L.VaArg{} -> unsupported++ where+ liftMemType' = either typeErr return . liftMemType++ typeErr msg =+    malformedLLVMModule "Invalid type when translating instruction"+       [ fromString (showInstr instr)+       , fromString msg+       ]++ unsupported = reportError $ App $ StringLit $ UnicodeLiteral $ Text.pack $+                 unwords ["unsupported instruction", showInstr instr]++arithOp :: (?transOpts :: TranslationOptions) =>+  L.ArithOp ->+  MemType ->+  LLVMExpr s arch ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+arithOp op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) =+  VecExpr tp <$> sequence (Seq.zipWith (\x y -> arithOp op tp x y) xs ys)++arithOp op _ x y =+  case (asScalar x, asScalar y) of+    (Scalar _ ty@(LLVMPointerRepr w)  x',+     Scalar _    (LLVMPointerRepr w') y')+      | Just Refl <- testEquality w PtrWidth+      , Just Refl <- testEquality w w' ->+        do z <- pointerOp op x' y'+           return (BaseExpr ty z)++      | Just Refl <- testEquality w w' ->+        do xbv <- pointerAsBitvectorExpr w x'+           ybv <- pointerAsBitvectorExpr w y'+           z   <- intop op w xbv ybv+           return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w z))++    (Scalar _archProxy (FloatRepr fi) x',+     Scalar _archPrxy' (FloatRepr fi') y')+      | Just Refl <- testEquality fi fi' ->+        do ex <- fop fi x' y'+           return (BaseExpr (FloatRepr fi) ex)++    _ -> reportError+           $ fromString+           $ unwords ["binary arithmetic operation on unsupported values",+                         show x, show y]++  where+  fop :: FloatInfoRepr fi ->+         Expr LLVM s (FloatType fi) ->+         Expr LLVM s (FloatType fi) ->+         LLVMGenerator s arch ret (Expr LLVM s (FloatType fi))+  fop fi a b =+    case op of+       L.FAdd ->+         return $ App $ FloatAdd fi RNE a b+       L.FSub ->+         return $ App $ FloatSub fi RNE a b+       L.FMul ->+         return $ App $ FloatMul fi RNE a b+       L.FDiv ->+         return $ App $ FloatDiv fi RNE a b+       L.FRem -> do+         return $ App $ FloatRem fi a b+       _ -> reportError+              $ fromString+              $ unwords [ "unsupported floating-point arith operation"+                        , show op, show x, show y+                        ]++unaryArithOp :: (?transOpts :: TranslationOptions) =>+  L.UnaryArithOp ->+  MemType ->+  LLVMExpr s arch ->+  LLVMGenerator s arch ret (LLVMExpr s arch)+unaryArithOp op (VecType n tp) (explodeVector n -> Just xs) =+  VecExpr tp <$> sequence (fmap (\x -> unaryArithOp op tp x) xs)++unaryArithOp op _ x =+  case asScalar x of+    Scalar _archProxy (FloatRepr fi) x' ->+        do ex <- fop fi x'+           return (BaseExpr (FloatRepr fi) ex)++    _ -> reportError+           $ fromString+           $ unwords ["unary arithmetic operation on unsupported value",+                         show x]++  where+  fop :: FloatInfoRepr fi ->+         Expr LLVM s (FloatType fi) ->+         LLVMGenerator s arch ret (Expr LLVM s (FloatType fi))+  fop fi a =+    case op of+       L.FNeg ->+         return $ App $ FloatNeg fi a++-- | Generate a call to an LLVM function, without any special+--   handling for debug intrinsics or breakpoints.+callOrdinaryFunction ::+   Maybe L.Instr {- ^ The instruction causing this call -} ->+   Bool    {- ^ Is the function a tail call? -} ->+   L.Type  {- ^ type of the function to call -} ->+   L.Value {- ^ function value to call -} ->+   [L.Typed L.Value] {- ^ argument list -} ->+   (LLVMExpr s arch -> LLVMGenerator s arch ret ()) {- ^ assignment continuation for return value -} ->+   LLVMGenerator s arch ret ()+callOrdinaryFunction instr _tailCall fnTy@(L.FunTy lretTy _largTys _varargs) fn args assign_f = do+  let err :: String -> a+      err = \msg -> malformedLLVMModule "Invalid type in function call" $+                       [ fromString msg ]+                       +++                       maybe [] ((:[]) . fromString . showInstr) instr++  fnTy'  <- either err return $ liftMemType (L.PtrTo fnTy)+  retTy' <- either err return $ liftRetType lretTy+  fn'    <- transValue fnTy' fn+  args'  <- mapM (\v -> transTypedValue v) args++  let ?err = err+  unpackArgs args' $ \_archProxy argTypes args'' ->+    llvmRetTypeAsRepr retTy' $ \retTy ->+      case asScalar fn' of+        Scalar _ PtrRepr ptr -> do+          memVar <- getMemVar+          v   <- extensionStmt (LLVM_LoadHandle memVar (Just fnTy) ptr argTypes retTy)+          ret <- call v args''+          assign_f (BaseExpr retTy ret)+        _ -> fail $ unwords ["unsupported function value", show fn]++callOrdinaryFunction instr _tailCall fnTy _fn _args _assign_f =+  reportError $ App $ StringLit $ UnicodeLiteral $ Text.pack $ unlines $+    [ "[callFunction] Unsupported function type: " ++ show fnTy ]+    +++    maybe [] ( (:[]) . show) instr+++-- | Generate a call to an LLVM function, generating special support+-- for debugging intrinsics and breakpoint functions.+callFunction :: forall s arch ret.+   (?transOpts :: TranslationOptions) =>+   Set L.Ident {- ^ Set of usable identifiers -} ->+   L.Instr {- ^ Source instruction of the call -} ->+   Bool    {- ^ Is the function a tail call? -} ->+   L.Type  {- ^ type of the function to call -} ->+   L.Value {- ^ function value to call -} ->+   [L.Typed L.Value] {- ^ argument list -} ->+   (LLVMExpr s arch -> LLVMGenerator s arch ret ()) {- ^ assignment continuation for return value -} ->+   LLVMGenerator s arch ret ()+callFunction defSet instr tailCall_ fnTy fn args assign_f++     -- Supports LLVM 4-12+     | L.ValSymbol "llvm.dbg.declare" <- fn+     , debugIntrinsics ?transOpts =+       do mbArgs <- dbgArgs defSet args+          case mbArgs of+            Right (asScalar -> Scalar _ PtrRepr ptr, lv, di) ->+              do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Declare ptr lv di))+                 return ()+            Left msg -> addWarning (Text.pack msg)+            _ -> addWarning "Unexpected argument in llvm.dbg.declare"++     -- Supports LLVM 6-12+     | L.ValSymbol "llvm.dbg.addr" <- fn+     , debugIntrinsics ?transOpts =+       do mbArgs <- dbgArgs defSet args+          case mbArgs of+            Right (asScalar -> Scalar _ PtrRepr ptr, lv, di) ->+              do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Addr ptr lv di))+                 return ()+            Left msg -> addWarning (Text.pack msg)+            _ -> addWarning "Unexpected argument in llvm.dbg.addr"++     -- Supports LLVM 6-12 (earlier versions had an extra argument)+     | L.ValSymbol "llvm.dbg.value" <- fn+     , debugIntrinsics ?transOpts =+       do mbArgs <- dbgArgs defSet args+          case mbArgs of+            Right (asScalar -> Scalar _ repr val, lv, di) ->+              do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Value repr val lv di))+                 return ()+            Left msg -> addWarning (Text.pack msg)+            _ -> addWarning "Unexpected argument in llvm.dbg.value"++     -- Skip calls to other debugging intrinsics.+     | L.ValSymbol nm <- fn+     , nm `elem` [ "llvm.dbg.label"+                 , "llvm.dbg.declare"+                 , "llvm.dbg.addr"+                 , "llvm.dbg.value"+                 , "llvm.lifetime.start"+                 , "llvm.lifetime.start.p0"+                 , "llvm.lifetime.start.p0i8"+                 , "llvm.lifetime.end"+                 , "llvm.lifetime.end.p0"+                 , "llvm.lifetime.end.p0i8"+                 , "llvm.invariant.start"+                 , "llvm.invariant.start.p0i8"+                 , "llvm.invariant.start.p0"+                 , "llvm.invariant.end"+                 , "llvm.invariant.end.p0i8"+                 , "llvm.invariant.end.p0"+                 ] = return ()++     | L.ValSymbol (L.Symbol nm) <- fn+     , testBreakpointFunction nm = do+        some_val_args <- mapM (\tv -> typedValueAsCrucibleValue tv) args+        case Ctx.fromList some_val_args of+          Some val_args -> do+            addBreakpointStmt (Text.pack nm) val_args++     | otherwise = callOrdinaryFunction (Just instr) tailCall_ fnTy fn args assign_f++-- | Match the arguments used by @dbg.addr@, @dbg.declare@, and @dbg.value@.+dbgArgs ::+  Set L.Ident {- ^ Set of usable identifiers -} ->+  [L.Typed L.Value] {- ^ debug call arguments -} ->+  LLVMGenerator s arch ret (Either String (LLVMExpr s arch, L.DILocalVariable, L.DIExpression))+dbgArgs defSet args =+    case args of+      [valArg, lvArg, diArg] ->+        case valArg of+          L.Typed _ (L.ValMd (L.ValMdValue val)) ->+            case lvArg of+              L.Typed _ (L.ValMd (L.ValMdDebugInfo (L.DebugInfoLocalVariable lv))) ->+                case diArg of+                  L.Typed _ (L.ValMd (L.ValMdDebugInfo (L.DebugInfoExpression di))) ->+                    let unusableIdents = Set.difference (useTypedVal val) defSet+                    in if Set.null unusableIdents then+                         do v <- transTypedValue val+                            pure (Right (v, lv, di))+                       else+                         do let msg = unwords (["dbg intrinsic def/use violation for:"] +++                                       map (show . LPP.ppIdent) (Set.toList unusableIdents))+                            pure (Left msg)+                  _ -> pure (Left ("dbg: argument 3 expected DIExpression, got: " ++ show diArg))+              _ -> pure (Left ("dbg: argument 2 expected local variable metadata, got: " ++ show lvArg))+          _ -> pure (Left ("dbg: argument 1 expected value metadata, got: " ++ show valArg))+      _ -> pure (Left ("dbg: expected 3 arguments, got: " ++ show (length args)))++typedValueAsCrucibleValue ::+  L.Typed L.Value ->+  LLVMGenerator s arch ret (Some (Value s))+typedValueAsCrucibleValue tv = case L.typedValue tv of+  L.ValIdent i -> do+    m <- use identMap+    case Map.lookup i m of+      Just (Left (Some r)) ->return $ Some $ RegValue r+      Just (Right (Some a)) -> return $ Some $ AtomValue a+      Nothing -> reportError $ fromString $+        "Could not find identifier " ++ show i ++ "."+  v -> reportError $ fromString $+    "Unsupported breakpoint parameter: " ++ show v ++ "."++++-- | Build a switch statement by decomposing it into a linear sequence of branches.+--   FIXME? this could be more efficient if we sort the list and do binary search instead...+buildSwitch :: (1 <= w)+            => NatRepr w+            -> Expr LLVM s (BVType w) -- ^ The expression to switch on+            -> L.BlockLabel        -- ^ The label of the current basic block+            -> L.BlockLabel        -- ^ The label of the default basic block if no other branch applies+            -> [(Integer, L.BlockLabel)] -- ^ The switch labels+            -> LLVMGenerator s arch ret a+buildSwitch _ _  curr_lab def [] =+   definePhiBlock curr_lab def+buildSwitch w ex curr_lab def ((i,l):bs) = do+   let test = App $ BVEq w ex $ App $ BVLit w (BV.mkBV w i)+   t_id <- newLabel+   f_id <- newLabel+   defineBlock t_id (definePhiBlock curr_lab l)+   defineBlock f_id (buildSwitch w ex curr_lab def bs)+   branch test t_id f_id++-- | Implement the phi-functions along the edge from one LLVM Basic block to another.+definePhiBlock :: L.BlockLabel      -- ^ The LLVM source basic block+               -> L.BlockLabel      -- ^ The LLVM target basic block+               -> LLVMGenerator s arch ret a+definePhiBlock l l' = do+  bim <- use blockInfoMap+  case Map.lookup l' bim of+    Nothing -> fail $ unwords ["label not found in label map:", show l']+    Just bi' -> do+      -- Collect all the relevant phi functions to evaluate+      let phi_funcs = maybe [] toList $ Map.lookup l (block_phi_map bi')++      -- NOTE: We evaluate all the right-hand sides of the phi nodes BEFORE+      --   we assign the values to their associated registers.  This preserves+      --   the expected semantics that phi functions are evaluated in the context+      --   of the previous basic block, and prevents unintended register shadowing.+      --   Otherwise loop-carried dependencies will sometimes end up with the wrong+      --   values.+      phiVals <- mapM evalPhi phi_funcs+      mapM_ assignPhi phiVals++      -- Now jump to the target code block+      jump (block_label bi')++ where evalPhi (ident,tp,v) = do+           t_v <- transTypedValue (L.Typed tp v)+           return (ident,t_v)+       assignPhi (ident,t_v) = do+           assignLLVMReg ident t_v+++-- | Assign a packed LLVM expression into the named LLVM register.+assignLLVMReg+        :: L.Ident+        -> LLVMExpr s arch+        -> LLVMGenerator s arch ret ()+assignLLVMReg ident rhs = do+  st <- get+  let idMap = st^.identMap+  case Map.lookup ident idMap of+    Just (Left lhs) -> do+      doAssign lhs rhs+    Just (Right _) -> fail $ "internal: Value cannot be assigned to."+    Nothing  -> fail $ unwords ["register not found in register map:", show ident]++-- | Given a register and an expression shape, assign the expressions in the right-hand-side+--   into the register left-hand side.+doAssign :: forall s arch ret.+      Some (Reg s)+   -> LLVMExpr s arch -- ^ the RHS values to assign+   -> LLVMGenerator s arch ret ()+doAssign (Some r) (BaseExpr tpr ex) =+   case testEquality (typeOfReg r) tpr of+     Just Refl -> assignReg r ex+     Nothing -> reportError $ fromString $ unwords ["type mismatch when assigning register", show r, show (typeOfReg r) , show tpr]+doAssign (Some r) (StructExpr vs) = do+   let ?err = fail+   unpackArgs (map snd $ toList vs) $ \_archProxy ctx asgn ->+     case testEquality (typeOfReg r) (StructRepr ctx) of+       Just Refl -> assignReg r (mkStruct ctx asgn)+       Nothing -> reportError $ fromString $ unwords ["type mismatch when assigning structure to register", show r, show (StructRepr ctx)]+doAssign (Some r) (ZeroExpr tp) = do+  let ?err = fail+  zeroExpand (proxy# :: Proxy# arch) tp $ \_archProxy (tpr :: TypeRepr t) (ex :: Expr LLVM s t) ->+    case testEquality (typeOfReg r) tpr of+      Just Refl -> assignReg r ex+      Nothing -> reportError $ fromString $ "type mismatch when assigning zero value"+doAssign (Some r) (UndefExpr tp) = do+  let ?err = fail+  undefExpand (proxy# :: Proxy# arch) tp $ \_archProxy (tpr :: TypeRepr t) (ex :: Expr LLVM s t) ->+    case testEquality (typeOfReg r) tpr of+      Just Refl -> assignReg r ex+      Nothing -> reportError $ fromString $ "type mismatch when assigning undef value"+doAssign (Some r) (VecExpr tp vs) = do+  let ?err = fail+  llvmTypeAsRepr tp $ \tpr ->+    unpackVec (proxy# :: Proxy# arch) tpr (toList vs) $ \ex ->+      case testEquality (typeOfReg r) (VectorRepr tpr) of+        Just Refl -> assignReg r ex+        Nothing -> reportError $ fromString $ "type mismatch when assigning vector value"
+ src/Lang/Crucible/LLVM/Translation/Monad.hs view
@@ -0,0 +1,268 @@+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Monad+-- Description      : Translation monad for LLVM and support operations+-- Copyright        : (c) Galois, Inc 2018+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+-----------------------------------------------------------------------+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}++module Lang.Crucible.LLVM.Translation.Monad+  ( -- * Generator monad+    LLVMGenerator+  , LLVMGenerator'+  , LLVMState(..)+  , identMap+  , blockInfoMap+  , translationWarnings+  , functionSymbol+  , addWarning+  , LLVMTranslationWarning(..)+  , IdentMap+  , LLVMBlockInfo(..)+  , LLVMBlockInfoMap+  , buildBlockInfoMap+  , initialState+  , getMemVar++    -- * Malformed modules+  , MalformedLLVMModule(..)+  , malformedLLVMModule+  , renderMalformedLLVMModule++    -- * LLVMContext+  , LLVMContext(..)+  , llvmTypeCtx+  , mkLLVMContext++  , useTypedVal+  ) where++import Control.Lens hiding (op, (:>), to, from )+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.State.Strict (MonadState(..))+import Data.IORef (IORef, modifyIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import Data.Text (Text)++import qualified Text.LLVM.AST as L++import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr as NatRepr+import           Data.Parameterized.Some++import           Lang.Crucible.CFG.Generator+import           Lang.Crucible.Panic ( panic )++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.Extension+import           Lang.Crucible.LLVM.MalformedLLVMModule+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.Translation.BlockInfo+import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.Types++------------------------------------------------------------------------+-- ** LLVMContext++-- | Information about the LLVM module.+data LLVMContext arch+   = LLVMContext+   { -- | Map LLVM symbols to their associated state.+     llvmArch       :: ArchRepr arch+   , llvmPtrWidth   :: forall a. (16 <= (ArchWidth arch) => NatRepr (ArchWidth arch) -> a) -> a+   , llvmMemVar     :: GlobalVar Mem+   , _llvmTypeCtx   :: TypeContext+     -- | For each global variable symbol, compute the set of+     --   aliases to that symbol+   , llvmGlobalAliases   :: Map L.Symbol (Set L.GlobalAlias)+     -- | For each function symbol, compute the set of+     --   aliases to that symbol+   , llvmFunctionAliases :: Map L.Symbol (Set L.GlobalAlias)+   }++llvmTypeCtx :: Simple Lens (LLVMContext arch) TypeContext+llvmTypeCtx = lens _llvmTypeCtx (\s v -> s{ _llvmTypeCtx = v })++mkLLVMContext :: GlobalVar Mem+              -> L.Module+              -> IO (Some LLVMContext)+mkLLVMContext mvar m = do+  let (errs, typeCtx) = typeContextFromModule m+  unless (null errs) $+    malformedLLVMModule "Failed to construct LLVM type context" errs+  let dl = llvmDataLayout typeCtx++  case mkNatRepr (ptrBitwidth dl) of+    Some (wptr :: NatRepr wptr) | Just LeqProof <- testLeq (knownNat @16) wptr ->+      withPtrWidth wptr $+        do let archRepr = X86Repr wptr -- FIXME! we should select the architecture based on+                                       -- the target triple, but llvm-pretty doesn't capture this+                                       -- currently.+           let ctx :: LLVMContext (X86 wptr)+               ctx = LLVMContext+                     { llvmArch     = archRepr+                     , llvmMemVar   = mvar+                     , llvmPtrWidth = \x -> x wptr+                     , _llvmTypeCtx = typeCtx+                     , llvmGlobalAliases = mempty   -- these are computed later+                     , llvmFunctionAliases = mempty -- these are computed later+                     }+           return (Some ctx)+    _ ->+      fail ("Cannot load LLVM bitcode file with illegal pointer width: " ++ show (dl^.ptrSize))+++-- | A monad providing state and continuations for translating LLVM expressions+-- to CFGs.+type LLVMGenerator s arch ret a =+  (?lc :: TypeContext, HasPtrWidth (ArchWidth arch)) =>+    Generator LLVM s (LLVMState arch) ret IO a++-- | @LLVMGenerator@ without the constraint, can be nested further inside monads.+type LLVMGenerator' s arch ret =+  Generator LLVM s (LLVMState arch) ret IO+++-- LLVMState++getMemVar :: LLVMGenerator s arch reg (GlobalVar Mem)+getMemVar = llvmMemVar . llvmContext <$> get++-- | Maps identifiers to an associated register or defined expression.+type IdentMap s = Map L.Ident (Either (Some (Reg s)) (Some (Atom s)))++-- | A warning generated during translation+data LLVMTranslationWarning =+  LLVMTranslationWarning+    L.Symbol  -- ^ Function name in which the warning was generated+    Position  -- ^ Source position where the warning was generated+    Text      -- ^ Description of the warning++data LLVMState arch s+   = LLVMState+   { -- | Map from identifiers to associated register shape+     _identMap :: !(IdentMap s)+   , _blockInfoMap :: !(LLVMBlockInfoMap s)+   , llvmContext :: LLVMContext arch+   , _translationWarnings :: IORef [LLVMTranslationWarning]+   , _functionSymbol :: L.Symbol+   }++identMap :: Lens' (LLVMState arch s) (IdentMap s)+identMap = lens _identMap (\s v -> s { _identMap = v })++blockInfoMap :: Lens' (LLVMState arch s) (LLVMBlockInfoMap s)+blockInfoMap = lens _blockInfoMap (\s v -> s { _blockInfoMap = v })++translationWarnings :: Lens' (LLVMState arch s) (IORef [LLVMTranslationWarning])+translationWarnings = lens _translationWarnings (\s v -> s { _translationWarnings = v })++functionSymbol :: Lens' (LLVMState arch s) L.Symbol+functionSymbol = lens _functionSymbol (\s v -> s{ _functionSymbol = v })++addWarning :: Text -> LLVMGenerator s arch ret ()+addWarning warn =+  do r <- use translationWarnings+     s <- use functionSymbol+     p <- getPosition+     liftIO (modifyIORef r ((LLVMTranslationWarning s p warn):))+++-- | Given a list of LLVM formal parameters and a corresponding crucible+-- register assignment, build an IdentMap mapping LLVM identifiers to+-- corresponding crucible registers.+buildIdentMap :: (?lc :: TypeContext, HasPtrWidth wptr)+              => [L.Typed L.Ident]+              -> Bool -- ^ varargs+              -> CtxRepr ctx+              -> Ctx.Assignment (Atom s) ctx+              -> IdentMap s+              -> IdentMap s+buildIdentMap ts True ctx asgn m =+  -- Vararg functions are translated as taking a vector of extra arguments+  packBase (VectorRepr AnyRepr) ctx asgn $ \_x ctx' asgn' ->+    buildIdentMap ts False ctx' asgn' m+buildIdentMap [] _ ctx _ m+  | Ctx.null ctx = m+  | otherwise =+      panic "crucible-llvm:Translation.buildIdentMap"+      [ "buildIdentMap: passed arguments do not match LLVM input signature" ]+buildIdentMap (ti:ts) _ ctx asgn m = do+  let ty = case liftMemType (L.typedType ti) of+             Right t -> t+             Left err -> panic "crucible-llvm:Translation.buildIdentMap"+                         [ "Error attempting to lift type " <> show ti+                         , show err+                         ]+  packType ty ctx asgn $ \x ctx' asgn' ->+     buildIdentMap ts False ctx' asgn' (Map.insert (L.typedValue ti) (Right x) m)++-- | Build the initial LLVM generator state upon entry to to the entry point of a function.+initialState :: (?lc :: TypeContext, HasPtrWidth wptr)+             => L.Define+             -> LLVMContext arch+             -> CtxRepr args+             -> Ctx.Assignment (Atom s) args+             -> IORef [LLVMTranslationWarning]+             -> LLVMState arch s+initialState d llvmctx args asgn warnRef =+   let m = buildIdentMap (reverse (L.defArgs d)) (L.defVarArgs d) args asgn Map.empty in+     LLVMState { _identMap = m+               , _blockInfoMap = Map.empty+               , llvmContext = llvmctx+               , _translationWarnings = warnRef+               , _functionSymbol = L.defName d+               }++-- | Given an LLVM type and a type context and a register assignment,+--   peel off the rightmost register from the assignment, which is+--   expected to match the given LLVM type.  Pass the register and+--   the remaining type and register context to the given continuation.+--+--   This procedure is used to set up the initial state of the+--   registers at the entry point of a function.+packType :: HasPtrWidth wptr+         => MemType+         -> CtxRepr ctx+         -> Ctx.Assignment (Atom s) ctx+         -> (forall ctx'. Some (Atom s) -> CtxRepr ctx' -> Ctx.Assignment (Atom s) ctx' -> a)+         -> a+packType tp ctx asgn k =+   llvmTypeAsRepr tp $ \repr ->+     packBase repr ctx asgn k++packBase+    :: TypeRepr tp+    -> CtxRepr ctx+    -> Ctx.Assignment (Atom s) ctx+    -> (forall ctx'. Some (Atom s) -> CtxRepr ctx' -> Ctx.Assignment (Atom s) ctx' -> a)+    -> a+packBase ctp ctx0 asgn k =+  case ctx0 of+    ctx' Ctx.:> ctp' ->+      case testEquality ctp ctp' of+        Nothing -> error $ unwords ["crucible type mismatch",show ctp,show ctp']+        Just Refl ->+          let asgn' = Ctx.init asgn+              idx   = Ctx.nextIndex (Ctx.size asgn')+           in k (Some (asgn Ctx.! idx))+                ctx'+                asgn'+    _ -> error "packType: ran out of actual arguments!"
+ src/Lang/Crucible/LLVM/Translation/Options.hs view
@@ -0,0 +1,55 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Options+-- Description      : Definition of options that can be tweaked during LLVM translation+-- Copyright        : (c) Galois, Inc 2021+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------+module Lang.Crucible.LLVM.Translation.Options+  ( TranslationOptions(..)+  , defaultTranslationOptions+  , debugIntrinsicsTranslationOptions+  ) where++-- | This datatype encodes a variety of tweakable settings that apply during+--   LLVM translation.+data TranslationOptions+  = TranslationOptions+    { debugIntrinsics :: !Bool+      -- ^ Should we translate @llvm.dbg@ intrinsic statements? The upside to+      --   translating them is that they encode debugging information about a+      --   program that can be useful for external clients. The downside is+      --   that they can bloat the size of translated programs, despite being+      --   no-ops during simulation.+    , laxArith :: !Bool+      -- ^ Should we omit proof obligations related to arithmetic overflow+      --   and similar assertions?+    , optLoopMerge :: !Bool+      -- ^ Should we insert merge blocks in loops with early exits (i.e. breaks+      --   or returns)? This may improve simulation performance.+    }++-- | The default translation options:+--+-- * Do not translate @llvm.dbg@ intrinsic statements+--+-- * Do not produce proof obligations for arithmetic-related assertions.+--+-- * Do not insert merge blocks in loops with early exits.+defaultTranslationOptions :: TranslationOptions+defaultTranslationOptions =+  TranslationOptions+  { debugIntrinsics = False+  , laxArith = False+  , optLoopMerge = False+  }++-- | Like 'defaultTranslationOptions', but @llvm.dbg@ intrinsic statements are+-- translated.+debugIntrinsicsTranslationOptions :: TranslationOptions+debugIntrinsicsTranslationOptions =+  defaultTranslationOptions+  { debugIntrinsics = True+  }
+ src/Lang/Crucible/LLVM/Translation/Types.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Translation.Types+-- Description      : Translation of LLVM AST into Crucible control-flow graph+-- Copyright        : (c) Galois, Inc 2014-2015+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+--+--+-- This module defines the translation from LLVM types to Crucible types.+--+-- The translation of the LLVM types themselves is not so difficult;+-- however, navigating the fact that Crucible expressions are strongly+-- typed at the Haskell level, whereas the LLVM types are not makes for+-- some slightly strange programming idioms.  In particular, all the+-- functions that do the type translation are written in a polymorphic+-- continuation-passing style.+----------------------------------------------------------------------++module Lang.Crucible.LLVM.Translation.Types+( VarArgs+, varArgsRepr+, llvmTypesAsCtx+, llvmTypeAsRepr+, llvmRetTypeAsRepr+, llvmDeclToFunHandleRepr+, llvmDeclToFunHandleRepr'+, LLVMPointerType+, pattern PtrWidth+, pattern LLVMPointerRepr+, declareFromDefine+, allModuleDeclares+, liftMemType+, liftRetType+, liftDeclare+) where++import qualified Control.Monad.Fail as Fail+import           Data.Foldable+import           Data.String++import qualified Text.LLVM.AST as L+import           Prettyprinter++import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.Some+++import           Lang.Crucible.Panic(panic)+import           Lang.Crucible.Types++import           Lang.Crucible.LLVM.MemModel.Pointer+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.MalformedLLVMModule+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP+import           Lang.Crucible.LLVM.TypeContext as TyCtx++++type VarArgs   = VectorType AnyType++varArgsRepr :: TypeRepr VarArgs+varArgsRepr = VectorRepr AnyRepr++------------------------------------------------------------------------+-- LLVM AST utilities++declareFromDefine :: L.Define -> L.Declare+declareFromDefine d =+  L.Declare { L.decLinkage = L.defLinkage d+            , L.decVisibility = L.defVisibility d+            , L.decRetType = L.defRetType d+            , L.decName = L.defName d+            , L.decArgs = L.typedType <$> L.defArgs d+            , L.decVarArgs = L.defVarArgs d+            , L.decAttrs   = L.defAttrs d+            , L.decComdat  = mempty+            }++-- | Return all declarations derived from both external symbols and+-- internal definitions.+allModuleDeclares :: L.Module -> [L.Declare]+allModuleDeclares m = L.modDeclares m ++ def_decls+  where def_decls = declareFromDefine <$> L.modDefines m++-----------------------------------------------------------------------------------------+-- Type translations++-- | Translate a list of LLVM expressions into a crucible type context,+--   which is passed into the given continuation.+llvmTypesAsCtx :: forall a wptr+                . HasPtrWidth wptr+               => [MemType]+               -> (forall ctx. CtxRepr ctx -> a)+               -> a+llvmTypesAsCtx xs f = go (concatMap (toList . llvmTypeToRepr) xs) Ctx.empty+ where go :: forall ctx. [Some TypeRepr] -> CtxRepr ctx -> a+       go []       ctx      = f ctx+       go (Some tp:tps) ctx = go tps (ctx Ctx.:> tp)++-- | Translate an LLVM type into a crucible type, which is passed into+--   the given continuation+llvmTypeAsRepr :: forall a wptr+                . HasPtrWidth wptr+               => MemType+               -> (forall tp. TypeRepr tp -> a)+               -> a+llvmTypeAsRepr xs f = go (llvmTypeToRepr xs)+ where go :: Maybe (Some TypeRepr) -> a+       go Nothing         = f UnitRepr+       go (Just (Some x)) = f x++-- | Translate an LLVM return type into a crucible type, which is passed into+--   the given continuation+llvmRetTypeAsRepr :: forall a wptr+                   . HasPtrWidth wptr+                  => Maybe MemType+                  -> (forall tp. TypeRepr tp -> a)+                  -> a+llvmRetTypeAsRepr Nothing   f = f UnitRepr+llvmRetTypeAsRepr (Just tp) f = llvmTypeAsRepr tp f++-- | Actually perform the type translation+llvmTypeToRepr :: HasPtrWidth wptr => MemType -> Maybe (Some TypeRepr)+llvmTypeToRepr (ArrayType _ tp)  = Just $ llvmTypeAsRepr tp (\t -> Some (VectorRepr t))+llvmTypeToRepr (VecType _ tp)    = Just $ llvmTypeAsRepr tp (\t-> Some (VectorRepr t))+llvmTypeToRepr (StructType si)   = Just $ llvmTypesAsCtx tps (\ts -> Some (StructRepr ts))+  where tps = map fiType $ toList $ siFields si+llvmTypeToRepr (PtrType _)  = Just $ Some (LLVMPointerRepr PtrWidth)+llvmTypeToRepr PtrOpaqueType = Just $ Some (LLVMPointerRepr PtrWidth)+llvmTypeToRepr FloatType    = Just $ Some (FloatRepr SingleFloatRepr)+llvmTypeToRepr DoubleType   = Just $ Some (FloatRepr DoubleFloatRepr)+llvmTypeToRepr X86_FP80Type = Just $ Some (FloatRepr X86_80FloatRepr)+llvmTypeToRepr MetadataType = Nothing+llvmTypeToRepr (IntType n) =+   case mkNatRepr n of+     Some w | Just LeqProof <- isPosNat w -> Just $ Some (LLVMPointerRepr w)+     _ -> panic "Translation.Types.llvmTypeToRepr"+              [" *** invalid integer width " ++ show n]++-- | Compute the function Crucible function signature+--   that corresponds to the given LLVM function declaration.+llvmDeclToFunHandleRepr+   :: HasPtrWidth wptr+   => FunDecl+   -> (forall args ret. CtxRepr args -> TypeRepr ret -> a)+   -> a+llvmDeclToFunHandleRepr decl k =+  llvmTypesAsCtx (fdArgTypes decl) $ \args ->+    llvmRetTypeAsRepr (fdRetType decl) $ \ret ->+      if fdVarArgs decl then+        k (args Ctx.:> varArgsRepr) ret+      else+        k args ret+++llvmDeclToFunHandleRepr' ::+   (?lc :: TypeContext, HasPtrWidth wptr, Fail.MonadFail m) =>+   L.Declare ->+   (forall args ret. CtxRepr args -> TypeRepr ret -> m a) ->+   m a+llvmDeclToFunHandleRepr' decl k =+  case liftDeclare decl of+    Left msg ->+      malformedLLVMModule+        ( "Invalid declaration for:" <+> fromString (show (L.decName decl)) )+        [ fromString (show (LPP.ppDeclare decl))+        , fromString msg+        ]++    Right fd -> llvmDeclToFunHandleRepr fd k
+ src/Lang/Crucible/LLVM/TypeContext.hs view
@@ -0,0 +1,286 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.TypeContext+-- Description      : Provides simulator type information and conversions.+-- Copyright        : (c) Galois, Inc 2011-2018+-- License          : BSD3+-- Maintainer       : Joe Hendrix <jhendrix@galois.com>+-- Stability        : provisional+--+-- This module provides functionality for querying simulator type+-- information in a module, and converting llvm-pretty types into+-- simulator types.+------------------------------------------------------------------------+{-# LANGUAGE ImplicitParams             #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeSynonymInstances       #-}++module Lang.Crucible.LLVM.TypeContext+  ( -- * LLVMContext+    TypeContext+  , mkTypeContext+  , typeContextFromModule+  , llvmDataLayout+  , llvmMetadataMap+  , AliasMap+  , llvmAliasMap+    -- * LLVMContext query functions.+  , compatMemTypes+  , compatRetTypes+  , compatMemTypeLists+  , lookupAlias+  , lookupMetadata+  , liftType+  , liftMemType+  , liftRetType+  , liftDeclare+  , asMemType+  ) where++import           Control.Lens+import           Control.Monad+import           Control.Monad.Except (MonadError(..))+import           Control.Monad.State (State, runState, modify, gets)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Text.LLVM as L+import qualified Text.LLVM.DebugUtils as L+import           Prettyprinter+import           Data.IntMap (IntMap)++import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.DataLayout+import qualified Lang.Crucible.LLVM.PrettyPrint as LPP++data IdentStatus+  = Resolved SymType+  | Active+  | Pending L.Type++data TCState = TCS { tcsDataLayout :: DataLayout+                   , tcsMap :: Map Ident IdentStatus+                     -- | Set of types encountered that are not supported by+                     -- the+                   , tcsUnsupported :: Set L.Type+                   , tcsUnresolvable :: Set Ident+                   }++runTC :: DataLayout+      -> Map Ident IdentStatus+      -> TC a+      -> ([Doc ann], a)+runTC pdl initMap m = over _1 tcsErrors . view swapped $ runState m tcs0+  where tcs0 = TCS { tcsDataLayout = pdl+                   , tcsMap =  initMap+                   , tcsUnsupported = Set.empty+                   , tcsUnresolvable = Set.empty+                   }++tcsErrors :: TCState -> [Doc ann]+tcsErrors tcs = (ppUnsupported <$> Set.toList (tcsUnsupported tcs))+             ++ (ppUnresolvable <$> Set.toList (tcsUnresolvable tcs))+  where ppUnsupported tp = pretty "Unsupported type:" <+> viaShow (LPP.ppType tp)+        ppUnresolvable i = pretty "Could not resolve identifier:" <+> viaShow (LPP.ppIdent i)+        -- TODO: update if llvm-pretty switches to prettyprinter++-- | Type lifter contains types that could not be parsed.+type TC = State TCState++recordUnsupported :: L.Type -> TC ()+recordUnsupported tp = modify fn+  where fn tcs = tcs { tcsUnsupported = Set.insert tp (tcsUnsupported tcs) }++-- | Returns the type bound to an identifier.+tcIdent :: Ident -> TC SymType+tcIdent i = do+  im <- gets tcsMap+  let retUnsupported = tp <$ modify fn+        where tp = UnsupportedType (L.Alias i)+              fn tcs = tcs { tcsUnresolvable = Set.insert i (tcsUnresolvable tcs) }+  case Map.lookup i im of+    Nothing -> retUnsupported+    Just (Resolved tp) -> return tp+    Just Active -> retUnsupported+    Just (Pending tp) -> do+        modify (ins Active)+        stp <- tcType tp+        stp <$ modify (ins (Resolved stp))+      where ins v tcs = tcs { tcsMap = Map.insert i v (tcsMap tcs) }++resolveMemType :: SymType -> TC (Maybe MemType)+resolveMemType = resolve+  where resolve (MemType mt) = return (Just mt)+        resolve (Alias i) = resolve =<< tcIdent i+        resolve _ = return Nothing++resolveRetType :: SymType -> TC (Maybe RetType)+resolveRetType = resolve+  where resolve (MemType mt) = return (Just (Just mt))+        resolve (Alias i) = resolve =<< tcIdent i+        resolve VoidType = return (Just Nothing)+        resolve _ = return Nothing++tcMemType :: L.Type -> TC (Maybe MemType)+tcMemType = resolveMemType <=< tcType++tcType :: L.Type -> TC SymType+tcType tp0 = do+  let badType = UnsupportedType tp0 <$ recordUnsupported tp0+  let maybeApp :: (a -> MemType) -> TC (Maybe a) -> TC SymType+      maybeApp f mmr = maybe badType (return . MemType . f) =<< mmr+  case tp0 of+    L.PrimType pt ->+      case pt of+        L.FloatType ft -> do+          case ft of+            L.Float -> return $ MemType FloatType+            L.Double -> return $ MemType DoubleType+            L.X86_fp80 -> return $ MemType X86_FP80Type+            _ -> badType+        L.Integer w -> return $ MemType $ IntType (fromIntegral w)+        L.Void -> return VoidType+        L.Metadata -> return $ MemType MetadataType+        _ -> badType+    L.Alias i -> return (Alias i)+    L.Array n etp -> maybeApp (ArrayType (fromIntegral n)) $ tcMemType etp+    L.FunTy res args va -> do+      mrt <- resolveRetType =<< tcType res+      margs <- traverse tcMemType args+      maybe badType (return . FunType) $+        FunDecl <$> mrt <*> sequence margs <*> pure va+    L.PtrTo tp ->  (MemType . PtrType) <$> tcType tp+    L.PtrOpaque -> return $ MemType PtrOpaqueType+    L.Struct tpl       -> maybeApp StructType $ tcStruct False tpl+    L.PackedStruct tpl -> maybeApp StructType $ tcStruct True  tpl+    L.Vector n etp -> maybeApp (VecType (fromIntegral n)) $ tcMemType etp+    L.Opaque -> return OpaqueType++-- | Constructs a function for obtaining target-specific size/alignment+-- information about structs.  The function produced corresponds to the+-- StructLayout object constructor in TargetData.cpp.+tcStruct :: Bool -> [L.Type] -> TC (Maybe StructInfo)+tcStruct packed fldTys = do+  pdl <- gets tcsDataLayout+  fieldMemTys <- traverse tcMemType fldTys+  return (mkStructInfo pdl packed <$> sequence fieldMemTys)+++type AliasMap = Map Ident SymType+type MetadataMap = IntMap L.ValMd++-- | Provides information about the types in an LLVM bitcode file.+data TypeContext = TypeContext+  { llvmDataLayout :: DataLayout+  , llvmMetadataMap :: MetadataMap+  , llvmAliasMap  :: AliasMap+  }++instance Show TypeContext where+  show = show . ppTypeContext++ppTypeContext :: TypeContext -> Doc ann+ppTypeContext lc =+    vcat (ppAlias <$> Map.toList (llvmAliasMap lc))+  where ppAlias (i,tp) = ppIdent i <+> equals <+> ppSymType tp++lookupAlias :: (?lc :: TypeContext, MonadError String m) => Ident -> m SymType+lookupAlias i =+  case llvmAliasMap ?lc ^. at i of+    Just stp -> return stp+    Nothing  -> throwError $ unwords ["Unknown type alias", show i]++lookupMetadata :: (?lc :: TypeContext) => Int -> Maybe L.ValMd+lookupMetadata x = view (at x) (llvmMetadataMap ?lc)++-- | If argument corresponds to a @MemType@ possibly via aliases,+-- then return it.  Otherwise, returns @Nothing@.+asMemType :: (?lc :: TypeContext, MonadError String m) => SymType -> m MemType+asMemType (MemType mt) = return mt+asMemType (Alias i) = asMemType =<< lookupAlias i+asMemType stp = throwError (unlines $ ["Expected memory type", show stp])++-- | If argument corresponds to a @RetType@ possibly via aliases,+-- then return it.  Otherwise, returns @Nothing@.+asRetType :: (?lc :: TypeContext, MonadError String m) => SymType -> m RetType+asRetType (MemType mt) = return (Just mt)+asRetType VoidType     = return Nothing+asRetType (Alias i)    = asRetType =<< lookupAlias i+asRetType stp = throwError (unlines $ ["Expected return type", show stp])++-- | Creates an LLVMContext from a parsed data layout and lists of types.+--  Errors reported in first argument.+mkTypeContext :: DataLayout -> MetadataMap -> [L.TypeDecl]  -> ([Doc ann], TypeContext)+mkTypeContext dl mdMap decls =+    let tps = Map.fromList [ (L.typeName d, L.typeValue d) | d <- decls ] in+    runTC dl (Pending <$> tps) $+      do aliases <- traverse tcType tps+         pure (TypeContext dl mdMap aliases)++-- | Utility function to creates an LLVMContext directly from a model.+typeContextFromModule :: L.Module -> ([Doc ann], TypeContext)+typeContextFromModule mdl = mkTypeContext dl (L.mkMdMap mdl) (L.modTypes mdl)+  where dl = parseDataLayout $ L.modDataLayout mdl++liftType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m SymType+liftType tp | null edocs = return stp+            | otherwise  = throwError $ unlines (map show edocs)+  where m0 = Resolved <$> llvmAliasMap ?lc+        (edocs,stp) = runTC (llvmDataLayout ?lc) m0 $ tcType tp++liftMemType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m MemType+liftMemType tp = asMemType =<< liftType tp++liftRetType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m RetType+liftRetType tp = asRetType =<< liftType tp++liftDeclare :: (?lc::TypeContext, MonadError String m) => L.Declare -> m FunDecl+liftDeclare decl =+  do args <- traverse liftMemType (L.decArgs decl)+     ret  <- liftRetType (L.decRetType decl)+     return $ FunDecl+              { fdRetType  = ret+              , fdArgTypes = args+              , fdVarArgs  = L.decVarArgs decl+              }++compatStructInfo :: StructInfo -> StructInfo -> Bool+compatStructInfo x y =+  siIsPacked x == siIsPacked y &&+    compatMemTypeVectors (siFieldTypes x) (siFieldTypes y)++-- | Returns true if types are bit-level compatible.+--+compatMemTypes :: MemType -> MemType -> Bool+compatMemTypes x0 y0 =+  case (x0, y0) of+    (IntType x, IntType y) -> x == y+    (FloatType, FloatType) -> True+    (DoubleType, DoubleType) -> True+    (PtrType{}, PtrType{})   -> True+    (PtrOpaqueType, PtrOpaqueType) -> True+    (ArrayType xn xt, ArrayType yn yt) ->+      xn == yn && xt `compatMemTypes` yt+    (VecType   xn xt, VecType   yn yt) ->+      xn == yn && xt `compatMemTypes` yt+    (StructType x, StructType y) -> x `compatStructInfo` y+    _ -> False++compatRetTypes :: RetType -> RetType -> Bool+compatRetTypes Nothing Nothing = True+compatRetTypes (Just x) (Just y) = compatMemTypes x y+compatRetTypes _ _ = False++compatMemTypeLists :: [MemType] -> [MemType] -> Bool+compatMemTypeLists [] [] = True+compatMemTypeLists (x:xl) (y:yl) =+  compatMemTypes x y && compatMemTypeLists xl yl+compatMemTypeLists _ _ = False++compatMemTypeVectors :: V.Vector MemType -> V.Vector MemType -> Bool+compatMemTypeVectors x y =+  V.length x == V.length y &&+  allOf traverse (uncurry compatMemTypes) (V.zip x y)
+ src/Lang/Crucible/LLVM/Types.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Types+-- Description      : Crucible type definitions related to LLVM+-- Copyright        : (c) Galois, Inc 2015-2016+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------+module Lang.Crucible.LLVM.Types+  ( Mem+  , memRepr+  , LLVMPointerType+  , LLVMPtr+  , pattern LLVMPointerRepr+  , pattern PtrRepr+  , pattern SizeT+  , pattern SSizeT+  , withPtrWidth+  , HasPtrWidth+  , pattern PtrWidth+  , GlobalSymbol(..)+  , globalSymbolName+  ) where++import           GHC.TypeNats+import           Data.Typeable++import           Data.Parameterized.Context++import qualified Text.LLVM.AST as L++import           Lang.Crucible.Simulator.RegValue+import           Lang.Crucible.Types++newtype GlobalSymbol = GlobalSymbol L.Symbol+  deriving (Typeable, Eq, Ord, Show)++globalSymbolName :: GlobalSymbol -> String+globalSymbolName (GlobalSymbol (L.Symbol nm)) = nm++-- | The 'CrucibleType' of an LLVM memory. @'RegValue' sym 'Mem'@ is+-- implemented as @'MemImpl' sym@.+type Mem = IntrinsicType "LLVM_memory" EmptyCtx++memRepr :: TypeRepr Mem+memRepr = knownRepr++-- | This constraint captures the idea that there is a distinguished+--   pointer width in scope which is appropriate according to the C+--   notion of pointer, and object size. In particular, it must be at+--   least 16-bits wide (as required for the @size_t@ type).+type HasPtrWidth w = (1 <= w, 16 <= w, ?ptrWidth :: NatRepr w)++pattern PtrWidth :: HasPtrWidth w => w ~ w' => NatRepr w'+pattern PtrWidth <- (testEquality ?ptrWidth -> Just Refl)+  where PtrWidth = ?ptrWidth++withPtrWidth :: forall w a. (16 <= w) => NatRepr w -> (HasPtrWidth w => a) -> a+withPtrWidth w a =+  case leqTrans (LeqProof :: LeqProof 1 16) (LeqProof :: LeqProof 16 w) of+    LeqProof -> let ?ptrWidth = w in a++-- | Crucible type of pointers/bitvector values of width @w@.+type LLVMPointerType w = IntrinsicType "LLVM_pointer" (EmptyCtx ::> BVType w)++-- | Symbolic LLVM pointer or bitvector values of width @w@.+type LLVMPtr sym w = RegValue sym (LLVMPointerType w)++-- | This pattern synonym makes it easy to build and destruct runtime+--   representatives of @'LLVMPointerType' w@.+pattern LLVMPointerRepr :: () => (1 <= w, ty ~ LLVMPointerType w) => NatRepr w -> TypeRepr ty+pattern LLVMPointerRepr w <- IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "LLVM_pointer") -> Just Refl)+                                           (Empty :> BVRepr w)+  where+    LLVMPointerRepr w = IntrinsicRepr knownSymbol (Empty :> BVRepr w)++-- | This pattern creates/matches against the TypeRepr for LLVM pointer values+--   that are of the distinguished pointer width.+pattern PtrRepr :: HasPtrWidth wptr => (ty ~ LLVMPointerType wptr) => TypeRepr ty+pattern PtrRepr = LLVMPointerRepr PtrWidth++-- | This pattern creates/matches against the TypeRepr for raw bitvector values+--   that are of the distinguished pointer width.+pattern SizeT :: HasPtrWidth wptr => (ty ~ BVType wptr) => TypeRepr ty+pattern SizeT = BVRepr PtrWidth++-- | This pattern creates/matches against the TypeRepr for raw signed bitvector values+--   that are of the distinguished pointer width.+pattern SSizeT :: HasPtrWidth wptr => (ty ~ BVType wptr) => TypeRepr ty+pattern SSizeT = BVRepr PtrWidth
+ src/Lang/Crucible/LLVM/Utils.hs view
@@ -0,0 +1,15 @@+------------------------------------------------------------------------+-- |+-- Module           : Lang.Crucible.LLVM.Utils+-- Description      : Miscellaneous utility functions.+-- Copyright        : (c) Galois, Inc 2021+-- License          : BSD3+-- Maintainer       : Rob Dockins <rdockins@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------+module Lang.Crucible.LLVM.Utils (applyUnless) where++-- | If the first argument is 'False', apply the second argument to the third.+-- Otherwise, simply return the third argument.+applyUnless :: Applicative f => Bool -> (a -> f a) -> a -> f a+applyUnless b f x = if b then pure x else f x
+ test/MemSetup.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module MemSetup+  (+    withInitializedMemory+  )+  where++import           Control.Lens ( (^.) )+import           Data.Parameterized.NatRepr+import           Data.Parameterized.Nonce+import           Data.Parameterized.Some+import qualified Text.LLVM.AST as L++import qualified What4.Expr as WE++import qualified Lang.Crucible.Backend as CB+import qualified Lang.Crucible.Backend.Simple as CBS+import           Lang.Crucible.FunctionHandle ( withHandleAllocator, HandleAllocator )++import qualified Lang.Crucible.LLVM.MemModel as LLVMMem+import           Lang.Crucible.LLVM.TypeContext++import qualified Lang.Crucible.LLVM.Extension as LLVME+import qualified Lang.Crucible.LLVM.Globals as LLVMG+import qualified Lang.Crucible.LLVM.MemModel as LLVMM+import qualified Lang.Crucible.LLVM.Translation as LLVMTr+++-- | Call 'initializeMemory' and get the result+withInitializedMemory :: forall a. L.Module+                      -> (forall wptr sym. ( ?lc :: TypeContext+                                           , LLVMMem.HasPtrWidth wptr+                                           , CB.IsSymInterface sym+                                           , LLVMMem.HasLLVMAnn sym+                                           , ?memOpts :: LLVMMem.MemOptions+                                           )+                          => LLVMMem.MemImpl sym+                          -> IO a)+                      -> IO a+withInitializedMemory mod' action =+  withLLVMCtx mod' $ \(ctx :: LLVMTr.LLVMContext arch) sym ->+    action @(LLVME.ArchWidth arch) =<< LLVMG.initializeAllMemory sym ctx mod'+++-- | Create an LLVM context from a module and make some assertions about it.+withLLVMCtx :: forall a. L.Module+            -> (forall arch sym bak.+                   ( ?lc :: TypeContext+                   , LLVMM.HasPtrWidth (LLVME.ArchWidth arch)+                   , CB.IsSymBackend sym bak+                   , LLVMMem.HasLLVMAnn sym+                   , ?memOpts :: LLVMMem.MemOptions+                   )+                => LLVMTr.LLVMContext arch+                -> bak+                -> IO a)+            -> IO a+withLLVMCtx mod' action =+  let -- This is a separate function because we need to use the scoped type variable+      -- @s@ in the binding of @sym@, which is difficult to do inline.+      with :: forall s. NonceGenerator IO s -> HandleAllocator -> IO a+      with nonceGen halloc = do+        sym <- WE.newExprBuilder WE.FloatRealRepr WE.EmptyExprBuilderState nonceGen+        bak <- CBS.newSimpleBackend sym+        let ?memOpts = LLVMMem.defaultMemOptions+        let ?transOpts = LLVMTr.defaultTranslationOptions+        memVar <- LLVMM.mkMemVar "test_llvm_memory" halloc+        Some mtrans <- LLVMTr.translateModule halloc memVar mod'+        let ctx = mtrans ^. LLVMTr.transContext+        case LLVMTr.llvmArch ctx            of { LLVME.X86Repr width ->+        case assertLeq (knownNat @1)  width of { LeqProof      ->+        case assertLeq (knownNat @16) width of { LeqProof      -> do+          let ?ptrWidth = width+          let ?lc = LLVMTr._llvmTypeCtx ctx+          let ?recordLLVMAnnotation = \_ _ _ -> pure ()+          action ctx bak+        }}}+  in withIONonceGenerator $ \nonceGen ->+     withHandleAllocator  $ \halloc   -> with nonceGen halloc+++assertLeq :: forall m n . NatRepr m -> NatRepr n -> LeqProof m n+assertLeq m n =+  case testLeq m n of+    Just LeqProof -> LeqProof+    Nothing       -> error $ "No LeqProof for " ++ show m ++ " and " ++ show n
+ test/TestFunctions.hs view
@@ -0,0 +1,79 @@+module TestFunctions+  (+    functionTests+  )+where++import qualified Data.Map.Strict as Map++import qualified Test.Tasty as T+import           Test.Tasty.HUnit ( testCase, (@=?) )++import qualified Text.LLVM.AST as L++import qualified Lang.Crucible.LLVM.MemModel as LLVMMem++import MemSetup ( withInitializedMemory )+++functionTests :: T.TestTree+functionTests =+  T.testGroup "Functions" $++  -- The following ensures that Crucible treats aliases to functions properly++  let alias = L.GlobalAlias+              { L.aliasLinkage = Nothing+              , L.aliasVisibility = Nothing+              , L.aliasName = L.Symbol "aliasName"+              , L.aliasType =+                  L.FunTy+                  (L.PrimType L.Void)+                  [ L.PtrTo (L.Alias (L.Ident "class.std::cls")) ]+                  False+              , L.aliasTarget =+                  L.ValSymbol (L.Symbol "defName")+              }++      def = L.Define+            { L.defLinkage = Just L.WeakODR+            , L.defVisibility = Nothing+            , L.defRetType = L.PrimType L.Void+            , L.defName = L.Symbol "defName"+            , L.defArgs =+                [ L.Typed+                  { L.typedType = L.PtrTo (L.Alias (L.Ident "class.std::cls"))+                  , L.typedValue = L.Ident "0"+                  }+                ]+            , L.defVarArgs = False+            , L.defAttrs = []+            , L.defSection = Nothing+            , L.defGC = Nothing+            , L.defBody =+                [ L.BasicBlock+                  { L.bbLabel = Just (L.Anon 1)+                  , L.bbStmts =+                      [ L.Result+                        (L.Ident "2")+                        (L.Alloca+                          (L.PtrTo+                            (L.Alias (L.Ident "class.std::cls"))) Nothing (Just 8))+                        []+                      , L.Effect L.RetVoid []+                      ]+                  }+                ]+            , L.defMetadata = mempty+            , L.defComdat = Nothing+            }+  in [ testCase "initializeMemory (functions)" $+       let mod'    = L.emptyModule { L.modDefines = [def]+                                   , L.modAliases = [alias]+                                   }+           inMap k = (Just () @=?) . fmap (const ()) . Map.lookup k+       in withInitializedMemory mod' $ \memImpl ->+         inMap+         (L.Symbol "aliasName")+         (LLVMMem.memImplGlobalMap memImpl)+     ]
+ test/TestGlobals.hs view
@@ -0,0 +1,79 @@+module TestGlobals+  (+    globalTests+  )+  where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import qualified Test.Tasty as T+import           Test.Tasty.HUnit ( testCase, (@=?) )++import qualified Text.LLVM.AST as L++import qualified Lang.Crucible.LLVM.MemModel as LLVMMem+import           Lang.Crucible.LLVM.Translation.Aliases++import           MemSetup ( withInitializedMemory )+++globalTests :: T.TestTree+globalTests =+  T.testGroup "Global Aliases" $ concat+  [+    ------------- Handling of global aliases++    -- It would be nice to have access to the Arbitrary instances for L.AST from+    -- llvm-pretty-bc-parser here.+    let mkGlobal name = L.Global (L.Symbol name) L.emptyGlobalAttrs L.Opaque Nothing Nothing Map.empty+        mkAlias  name global = L.GlobalAlias { L.aliasLinkage    = Nothing+                                             , L.aliasVisibility = Nothing+                                             , L.aliasName       = L.Symbol name+                                             , L.aliasType       = L.Opaque+                                             , L.aliasTarget     = L.ValSymbol (L.Symbol global)+                                             }+        mkModule as   gs     = L.emptyModule { L.modGlobals = gs+                                             , L.modAliases = as+                                             }+    in+      [ testCase "globalAliases: empty module" $+        withInitializedMemory (mkModule [] []) $ \_ ->+          Map.empty @=? globalAliases L.emptyModule++      , testCase "globalAliases: singletons, aliased" $+        let g = mkGlobal "g"+            a = mkAlias  "a" "g"+        in withInitializedMemory (mkModule [] []) $ \_ ->+          Map.singleton (L.globalSym g) (Set.singleton a) @=? globalAliases (mkModule [a] [g])++      , testCase "globalAliases: two aliases" $+        let g  = mkGlobal "g"+            a1 = mkAlias  "a1" "g"+            a2 = mkAlias  "a2" "g"+        in withInitializedMemory (mkModule [] []) $ \_ ->+          Map.singleton (L.globalSym g) (Set.fromList [a1, a2]) @=? globalAliases (mkModule [a1, a2] [g])+      ]++  , -- The following test ensures that SAW treats global aliases properly in that+    -- they are present in the @Map@ of globals after initializing the memory.++    let t = L.PrimType (L.Integer 2)+        mkGlobal name = L.Global (L.Symbol name) L.emptyGlobalAttrs t Nothing Nothing Map.empty+        mkAlias  name global = L.GlobalAlias { L.aliasLinkage    = Nothing+                                             , L.aliasVisibility = Nothing+                                             , L.aliasName       = L.Symbol name+                                             , L.aliasType       = t+                                             , L.aliasTarget     = L.ValSymbol (L.Symbol global)+                                             }+        mkModule as   gs     = L.emptyModule { L.modGlobals = gs+                                             , L.modAliases = as+                                             }+    in [ testCase "initializeMemory" $+         let mod'    = mkModule [mkAlias  "a" "g"] [mkGlobal "g"]+             inMap k = (Just () @=?) . fmap (const ()) . Map.lookup k+         in withInitializedMemory mod' $ \result ->+           inMap (L.Symbol "a") (LLVMMem.memImplGlobalMap result)+       ]++  ]
+ test/TestMemory.hs view
@@ -0,0 +1,604 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module TestMemory+  (+    memoryTests+  )+where++import           Control.Lens ( (^.), _1, _2 )+import           Control.Monad ( foldM, forM_, void )+import           Data.Foldable ( foldlM )+import qualified Data.Vector as V++import qualified Test.Tasty as T+import           Test.Tasty.HUnit ( testCase, (@=?), assertFailure )++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr ( knownNat )+import           Data.Parameterized.Nonce ( withIONonceGenerator )+import qualified What4.Expr as WE+import qualified What4.Expr.Builder as WE+import qualified What4.Config as What4+import qualified What4.Interface as What4+import           What4.ProblemFeatures ( noFeatures )+import qualified What4.Protocol.Online as W4O+import qualified What4.SatResult as W4Sat++import qualified Lang.Crucible.Backend as CB+import qualified Lang.Crucible.Backend.Online as CBO+import qualified Lang.Crucible.Simulator as CS+import qualified Lang.Crucible.Types as Crucible++import           Lang.Crucible.LLVM.DataLayout ( noAlignment )+import qualified Lang.Crucible.LLVM.DataLayout as LLVMD+import           Lang.Crucible.LLVM.MemModel ( doLoad, doStore, projectLLVM_bv, ptrAdd )+import qualified Lang.Crucible.LLVM.MemModel as LLVMMem+import qualified Lang.Crucible.LLVM.MemModel.Generic as LLVMMemG+++memoryTests :: T.TestTree+memoryTests = T.testGroup "Memory"+  [+    testArrayStride+  , testMemAllocs+  , testMemWritesIndexed+  , testMemArrayWithConstants+  , testMemArray+  , testPointerStore+  , testStructStore+  , testMemArrayCopy+  , testMemArraySet+  , testMemInvalidate+  ]++withMem ::+  LLVMD.EndianForm ->+  (forall bak sym scope solver st fs wptr .+    ( sym ~ WE.ExprBuilder scope st fs+    , bak ~ CBO.OnlineBackend solver scope st fs+    , CB.IsSymBackend sym bak+    , LLVMMem.HasLLVMAnn sym+    , W4O.OnlineSolver solver+    , LLVMMem.HasPtrWidth wptr+    , ?memOpts :: LLVMMem.MemOptions ) =>+    bak -> LLVMMem.MemImpl sym -> IO a) ->+  IO a+withMem endianess action = withIONonceGenerator $ \nonce_gen -> do+  sym <- WE.newExprBuilder WE.FloatIEEERepr WE.EmptyExprBuilderState nonce_gen+  CBO.withZ3OnlineBackend sym CBO.NoUnsatFeatures noFeatures $ \bak -> do+    let ?ptrWidth = knownNat @64+    let ?recordLLVMAnnotation = \_ _ _ -> pure ()+    let ?memOpts = LLVMMem.defaultMemOptions+    mem <- LLVMMem.emptyMem endianess+    action bak mem++setCacheTerms :: CB.IsSymInterface sym => sym -> Bool ->IO ()+setCacheTerms sym cache_terms_option = do+  cache_terms_setting <- What4.getOptionSetting WE.cacheTerms $ What4.getConfiguration sym+  void $ What4.setOpt cache_terms_setting cache_terms_option++userSymbol' :: String -> What4.SolverSymbol+userSymbol' s = case What4.userSymbol s of+  Left e -> error $ show e+  Right symbol -> symbol++assume :: (CB.IsSymBackend sym bak) => bak -> What4.Pred sym -> IO ()+assume bak p = do+  let sym = CB.backendGetSym bak+  loc <- What4.getCurrentProgramLoc sym+  CB.addAssumption bak (CB.GenericAssumption loc "assume" p)++checkSat ::+  W4O.OnlineSolver solver =>+  CBO.OnlineBackend solver scope st fs ->+  WE.BoolExpr scope ->+  IO (W4Sat.SatResult () ())+checkSat bak p =+  let err = fail "Online solving not enabled!" in+  CBO.withSolverProcess bak err $ \proc ->+     W4O.checkSatisfiable proc "" p+++testArrayStride :: T.TestTree+testArrayStride = testCase "array stride" $ withMem LLVMD.BigEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak+  sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024)+  (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment++  let byte_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @8+  let byte_storage_type = LLVMMem.bitvectorType 1+  let ptr_byte_repr = LLVMMem.LLVMPointerRepr $ knownNat @8++  init_array_val <- LLVMMem.LLVMValArray byte_storage_type <$>+    V.generateM (1024 * 1024)+      (\i -> LLVMMem.packMemValue sym byte_storage_type byte_type_repr+        =<< What4.bvLit sym (knownNat @8) (BV.mkBV knownNat (fromIntegral (mod i (512 * 1024)))))+  mem2 <- LLVMMem.storeRaw+    bak+    mem1+    base_ptr+    (LLVMMem.arrayType (1024 * 1024) byte_storage_type)+    noAlignment+    init_array_val++  stride <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (512 * 1024)++  i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth+  ptr_i <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvMul sym stride i+  ptr_i' <- ptrAdd sym ?ptrWidth ptr_i =<< What4.bvLit sym ?ptrWidth (BV.one ?ptrWidth)++  zero_bv <- What4.bvLit sym (knownNat @8) (BV.zero knownNat)+  mem3 <-+    doStore bak mem2 ptr_i byte_type_repr byte_storage_type noAlignment zero_bv+  one_bv <- What4.bvLit sym (knownNat @8) (BV.one knownNat)+  mem4 <-+    doStore bak mem3 ptr_i' byte_type_repr byte_storage_type noAlignment one_bv++  at_0_val <- projectLLVM_bv bak+    =<< doLoad bak mem4 base_ptr byte_storage_type ptr_byte_repr noAlignment+  (Just (BV.zero knownNat)) @=? What4.asBV at_0_val++  j <- What4.freshConstant sym (userSymbol' "j") $ What4.BaseBVRepr ?ptrWidth+  ptr_j <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvMul sym stride j+  ptr_j' <- ptrAdd sym ?ptrWidth ptr_j =<< What4.bvLit sym ?ptrWidth (BV.one ?ptrWidth)++  at_j_val <- projectLLVM_bv bak+    =<< doLoad bak mem4 ptr_j byte_storage_type ptr_byte_repr noAlignment+  (Just (BV.zero knownNat)) @=? What4.asBV at_j_val++  at_j'_val <- projectLLVM_bv bak+    =<< doLoad bak mem4 ptr_j' byte_storage_type ptr_byte_repr noAlignment+  (Just (BV.one knownNat)) @=? What4.asBV at_j'_val+++allocFreshArray ::+  ( CB.IsSymBackend sym bak, LLVMMem.HasLLVMAnn sym, LLVMMem.HasPtrWidth wptr+  , ?memOpts :: LLVMMem.MemOptions ) =>+  bak ->+  LLVMMem.MemImpl sym ->+  Integer ->+  IO (LLVMMem.LLVMPtr sym wptr, What4.SymArray sym (SingleCtx (What4.BaseBVType wptr)) (What4.BaseBVType 8), LLVMMem.MemImpl sym)+allocFreshArray bak mem sz = do+  let sym = CB.backendGetSym bak+  sz_bv <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth sz+  (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem sz_bv noAlignment+  arr <- What4.freshConstant+    sym+    (userSymbol' "a")+    (What4.BaseArrayRepr (Ctx.singleton $ What4.BaseBVRepr ?ptrWidth) (What4.BaseBVRepr (knownNat @8)))+  mem2 <- LLVMMem.doArrayStore bak mem1 base_ptr noAlignment arr sz_bv+  return (base_ptr, arr, mem2)+++-- | This test case verifies that the symbolic aspects of the SMT-backed array+-- memory model works (e.g., that constraints on symbolic indexes work as+-- expected)+testMemArray :: T.TestTree+testMemArray = testCase "smt array memory model" $ withMem LLVMD.BigEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak+  -- Make a fresh allocation (backed by a fresh SMT array) of size 1024*1024 bytes.+  -- The base pointer of the array is base_ptr+  sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024)+  (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment++  arr <- What4.freshConstant+    sym+    (userSymbol' "a")+    (What4.BaseArrayRepr+      (Ctx.singleton $ What4.BaseBVRepr ?ptrWidth)+      (What4.BaseBVRepr (knownNat @8)))+  mem2 <- LLVMMem.doArrayStore bak mem1 base_ptr noAlignment arr sz++  let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64+  let long_storage_type = LLVMMem.bitvectorType 8+  let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64++  -- Store a large known 8 byte value at a symbolic location in the array (at+  -- @i@ bytes from the beginning of the array).  The assumption constrains it+  -- such that the location is within the first 1024 bytes of the array.+  i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth+  ptr_i <- ptrAdd sym ?ptrWidth base_ptr i+  assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)+  some_val <- What4.bvLit sym (knownNat @64) (BV.mkBV knownNat 0x88888888f0f0f0f0)+  mem3 <-+    doStore bak mem2 ptr_i long_type_repr long_storage_type noAlignment some_val++  memset_ptr <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 2048)+  memset_val <- What4.bvLit sym knownNat (BV.mkBV knownNat 0)+  memset_sz <- What4.bvLit sym (knownNat @64) (BV.mkBV knownNat 10)+  mem4 <- LLVMMem.doMemset bak (knownNat @64) mem3 memset_ptr memset_val memset_sz++  -- Read that same value back and make sure that they are the same+  at_i_val <- projectLLVM_bv bak+    =<< doLoad bak mem4 ptr_i long_storage_type ptr_long_repr noAlignment+  res_i <- checkSat bak =<< What4.bvNe sym some_val at_i_val+  True @=? W4Sat.isUnsat res_i++  -- Allocate another fresh arbitrary constant and add it to the base pointer.+  -- Assume that i = j, then verify that reading from j yields the same value as+  -- was written at i.+  j <- What4.freshConstant sym (userSymbol' "j") $ What4.BaseBVRepr ?ptrWidth+  ptr_j <- ptrAdd sym ?ptrWidth base_ptr j+  assume bak =<< What4.bvEq sym i j+  at_j_val <- projectLLVM_bv bak+    =<< doLoad bak mem4 ptr_j long_storage_type ptr_long_repr noAlignment+  res_j <- checkSat bak =<< What4.bvNe sym some_val at_j_val+  True @=? W4Sat.isUnsat res_j+++-- | Like testMemArray, but using some concrete indexes in a few places.  This+-- test checks the implementation of saturated addition of two numbers.+--+-- This is simulating the use of an SMT array to represent a program stack, and+-- ensures that:+--+-- * Concrete indexing works as expected+-- * Goals that depend on the values of values stored in memory work+testMemArrayWithConstants :: T.TestTree+testMemArrayWithConstants = testCase "smt array memory model (with constant indexing)" $ do+  withMem LLVMD.LittleEndian $ \bak mem0 -> do+    let sym = CB.backendGetSym bak+    sz <- What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth (2 * 1024))+    (region_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment+    let mRepr = What4.BaseArrayRepr (Ctx.singleton (What4.BaseBVRepr ?ptrWidth)) (What4.BaseBVRepr (knownNat @8))+    backingArray <- What4.freshConstant sym (userSymbol' "backingArray") mRepr+    mem2 <- LLVMMem.doArrayStore bak mem1 region_ptr noAlignment backingArray sz++    let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64+    let long_storage_type = LLVMMem.bitvectorType 8+    let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64++    -- Make our actual base pointer the middle of the stack, to simulate having+    -- some active frames above us+    base_off <- What4.freshConstant sym (userSymbol' "baseOffset") (What4.BaseBVRepr ?ptrWidth)+    assume bak =<< What4.bvUlt sym base_off =<< (What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 10))+    base_ptr <- ptrAdd sym ?ptrWidth region_ptr base_off -- =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)++    -- Assume we have two arguments to our virtual function:+    param_a <- What4.freshConstant sym (userSymbol' "paramA") (What4.BaseBVRepr (knownNat @64))+    param_b <- What4.freshConstant sym (userSymbol' "paramB") (What4.BaseBVRepr (knownNat @64))++    -- The fake stack frame will start at @sp@ be:+    --+    -- sp+8  : Stack slot for spilling a+    slot_a <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 8)+    -- sp+16 : Stack slot for spilling b+    slot_b <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 16)+    -- sp+24 : Stack slot for local variable c+    slot_c <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 24)++    -- Store a and b onto the stack+    mem3 <- doStore bak mem2 slot_a long_type_repr long_storage_type noAlignment param_a+    mem4 <- doStore bak mem3 slot_b long_type_repr long_storage_type noAlignment param_b++    -- Read a and b off of the stack and compute c = a+b (storing the result on the stack in c's slot)+    valA0 <- projectLLVM_bv bak =<< doLoad bak mem4 slot_a long_storage_type ptr_long_repr noAlignment+    valB0 <- projectLLVM_bv bak =<< doLoad bak mem4 slot_b long_storage_type ptr_long_repr noAlignment+    mem5 <- doStore bak mem4 slot_c long_type_repr long_storage_type noAlignment =<< What4.bvAdd sym valA0 valB0+++    valA1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_a long_storage_type ptr_long_repr noAlignment+    valB1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_b long_storage_type ptr_long_repr noAlignment+    valC1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_c long_storage_type ptr_long_repr noAlignment++    -- Add some assumptions to make our assertion actually hold (i.e., avoiding overflow)+    let n64 = knownNat @64+    -- assume sym =<< What4.bvUlt sym param_a =<< What4.bvLit sym n64 (BV.mkBV n64 100)+    -- assume sym =<< What4.bvUlt sym param_b =<< What4.bvLit sym n64 (BV.mkBV n64 100)+    cLessThanA <- What4.bvSlt sym valC1 valA1+    cLessThanB <- What4.bvSlt sym valC1 valB1+    ifOverflow <- What4.orPred sym cLessThanA cLessThanB++    i64Max <- What4.bvLit sym n64 (BV.mkBV n64 0x7fffffffffffffff)+    clamped_c <- What4.bvIte sym ifOverflow i64Max valC1+    mem6 <- doStore bak mem5 slot_c long_type_repr long_storage_type noAlignment clamped_c++    valC2 <- projectLLVM_bv bak =<< doLoad bak mem6 slot_c long_storage_type ptr_long_repr noAlignment++    aLessThanC <- What4.bvSle sym param_a valC2+    bLessThanC <- What4.bvSle sym param_b valC2+    assertion <- What4.andPred sym aLessThanC bLessThanC+    goal <- What4.notPred sym assertion+    res <- checkSat bak goal+    True @=? W4Sat.isUnsat res+++-- | This test case checks the memcpy aspect of the SMT-backed array memory model+testMemArrayCopy :: T.TestTree+testMemArrayCopy = testCase "smt array copy memory model" $ withMem LLVMD.LittleEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak++  setCacheTerms sym True++  (dst_base_ptr, dst_arr, mem1) <- allocFreshArray bak mem0 (1024 * 1024)+  (src_base_ptr, src_arr, mem2) <- allocFreshArray bak mem1 1024++  i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth+  dst_ptr <- ptrAdd sym ?ptrWidth dst_base_ptr i+  assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)+  len <- What4.freshConstant sym (userSymbol' "l") $ What4.BaseBVRepr ?ptrWidth+  assume bak =<< What4.bvUlt sym len =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)+  mem3 <- LLVMMem.doMemcpy bak ?ptrWidth mem2 False dst_ptr src_base_ptr len++  zero_bv <- What4.bvLit sym ?ptrWidth $ BV.zero ?ptrWidth+  expected_arr <- What4.arrayCopy sym dst_arr i src_arr zero_bv len+  expected_val <- What4.arrayLookup sym expected_arr $ Ctx.singleton i++  actual_val <- projectLLVM_bv bak+    =<< doLoad bak mem3 dst_ptr (LLVMMem.bitvectorType 1) (LLVMMem.LLVMPointerRepr $ knownNat @8) noAlignment++  foo <- What4.bvEq sym expected_val actual_val+  (Just True) @=? What4.asConstantPred foo+++-- | This test case checks the memset aspect of the SMT-backed array memory model+testMemArraySet :: T.TestTree+testMemArraySet = testCase "smt array copy memory model" $ withMem LLVMD.LittleEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak+  setCacheTerms sym True++  (base_ptr, arr, mem1) <- allocFreshArray bak mem0 (1024 * 1024)++  i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth+  ptr_i <- ptrAdd sym ?ptrWidth base_ptr i+  assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)+  val <- What4.freshConstant sym (userSymbol' "v") $ What4.BaseBVRepr $ knownNat @8+  len <- What4.freshConstant sym (userSymbol' "l") $ What4.BaseBVRepr ?ptrWidth+  assume bak =<< What4.bvUlt sym len =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024)+  mem3 <- LLVMMem.doMemset bak ?ptrWidth mem1 ptr_i val len++  expected_arr <- What4.arraySet sym arr i val len+  expected_val <- What4.arrayLookup sym expected_arr $ Ctx.singleton i++  actual_val <- projectLLVM_bv bak+    =<< doLoad bak mem3 ptr_i (LLVMMem.bitvectorType 1) (LLVMMem.LLVMPointerRepr $ knownNat @8) noAlignment++  foo <- What4.bvEq sym expected_val actual_val+  (Just True) @=? What4.asConstantPred foo+++testMemWritesIndexed :: T.TestTree+testMemWritesIndexed = testCase "indexed memory writes" $ withMem LLVMD.BigEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak+  let count = 100 * 1000++  sz <- What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 8)+  (base_ptr1, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment+  (base_ptr2, mem2) <- LLVMMem.mallocRaw bak mem1 sz noAlignment++  let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64+  let long_storage_type = LLVMMem.bitvectorType 8+  let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64++  zero_val <- What4.bvLit sym (knownNat @64) (BV.zero knownNat)+  mem3 <- doStore+    bak+    mem2+    base_ptr1+    long_type_repr+    long_storage_type+    noAlignment+    zero_val++  mem4 <- foldlM+    (\mem' i ->+      doStore bak mem' base_ptr2 long_type_repr long_storage_type noAlignment+        =<< What4.bvLit sym (knownNat @64) i)+    mem3+    (BV.enumFromToUnsigned (BV.zero (knownNat @64)) (BV.mkBV knownNat count))++  forM_ [0 .. count] $ \_ -> do+    val1 <- projectLLVM_bv bak+      =<< doLoad bak mem4 base_ptr1 long_storage_type ptr_long_repr noAlignment+    (Just (BV.zero knownNat)) @=? What4.asBV val1++  val2 <- projectLLVM_bv bak+    =<< doLoad bak mem4 base_ptr2 long_storage_type ptr_long_repr noAlignment+  (Just (BV.mkBV knownNat count)) @=? What4.asBV val2++testMemAllocs :: T.TestTree+testMemAllocs =+  testCase "memory model alloc/free" $+  withMem LLVMD.BigEndian $ \bak mem0 ->+  do let sym = CB.backendGetSym bak+     sz1 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 128+     sz2 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 72+     sz3 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 32+     (ptr1, mem1) <- LLVMMem.mallocRaw bak mem0 sz1 noAlignment+     (ptr2, mem2) <- LLVMMem.mallocRaw bak mem1 sz2 noAlignment+     mem3 <- LLVMMem.doFree bak mem2 ptr2+     (ptr3, mem4) <- LLVMMem.mallocRaw bak mem3 sz3 noAlignment+     mem5 <- LLVMMem.doFree bak mem4 ptr1+     mem6 <- LLVMMem.doFree bak mem5 ptr3++     let isAllocated = LLVMMem.isAllocatedAlignedPointer sym ?ptrWidth noAlignment LLVMMem.Mutable+     assertions <-+       sequence+       [ isAllocated ptr1 (Just sz1) mem1+       , isAllocated ptr1 (Just sz1) mem2+       , isAllocated ptr1 (Just sz1) mem3+       , isAllocated ptr1 (Just sz1) mem4+       , isAllocated ptr1 (Just sz1) mem5 >>= What4.notPred sym+       , isAllocated ptr1 (Just sz1) mem6 >>= What4.notPred sym++       , isAllocated ptr2 (Just sz2) mem1 >>= What4.notPred sym+       , isAllocated ptr2 (Just sz2) mem2+       , isAllocated ptr2 (Just sz2) mem3 >>= What4.notPred sym+       , isAllocated ptr2 (Just sz2) mem4 >>= What4.notPred sym+       , isAllocated ptr2 (Just sz2) mem5 >>= What4.notPred sym+       , isAllocated ptr2 (Just sz2) mem6 >>= What4.notPred sym++       , isAllocated ptr3 (Just sz3) mem1 >>= What4.notPred sym+       , isAllocated ptr3 (Just sz3) mem2 >>= What4.notPred sym+       , isAllocated ptr3 (Just sz3) mem3 >>= What4.notPred sym+       , isAllocated ptr3 (Just sz3) mem4+       , isAllocated ptr3 (Just sz3) mem5+       , isAllocated ptr3 (Just sz3) mem6 >>= What4.notPred sym+       ]+     assertion <- foldM (What4.andPred sym) (What4.truePred sym) assertions+     res <- checkSat bak =<< What4.notPred sym assertion+     True @=? W4Sat.isUnsat res++-- | This test case checks that 'doInvalidate' behaves as expected with and+-- without 'laxLoadsAndStores' enabled.+testMemInvalidate :: T.TestTree+testMemInvalidate =+  testCase "memory invalidation" $ withMem LLVMD.BigEndian $ \bak mem0 ->+  do let sym = CB.backendGetSym bak+     sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 64+     let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64+         long_storage_type = LLVMMem.bitvectorType 8+     zero_val <- What4.bvLit sym (knownNat @64) (BV.zero knownNat)++     let withInvalidatedReadVal memOpts k = do+           let ?memOpts = memOpts+           -- First, allocate some memory on the stack...+           (ptr, mem1) <- LLVMMem.doAlloca bak mem0 sz noAlignment "<alloca>"+           -- ...write some value to it (the exact value is unimportant)...+           mem2 <- LLVMMem.doStore bak mem1 ptr+                                   long_type_repr long_storage_type+                                   noAlignment zero_val+           -- ...invalidate the memory...+           mem3 <- LLVMMem.doInvalidate bak ?ptrWidth mem2 ptr "<invalidate>" sz+           -- ...and finally, read from the invalidated memory.+           partVal <- LLVMMemG.readMem sym ?ptrWidth Nothing ptr+                                       long_storage_type noAlignment+                                       (LLVMMem.memImplHeap mem3)+           k partVal++         testLaxInvalidatedRead :: String -> LLVMMem.IndeterminateLoadBehavior -> IO ()+         testLaxInvalidatedRead stability indeterminateLoadBehavior =+           withInvalidatedReadVal (?memOpts{ LLVMMem.laxLoadsAndStores = True+                                           , LLVMMem.indeterminateLoadBehavior = indeterminateLoadBehavior+                                           }) $ \partVal ->+           case partVal of+             LLVMMem.NoErr p _val -> do+               res <- checkSat bak p+               True @=? W4Sat.isSat res+             LLVMMem.Err p -> assertFailure $ unlines+               [ "Reading from invalidated, " ++ stability ++ "-symbolic memory unexpectedly failed"+               , "Predicate: " ++ show p+               ]++     -- Test with laxLoadsAndStores disabled, where reading from invalidated+     -- memory should result in an error.+     withInvalidatedReadVal (?memOpts{LLVMMem.laxLoadsAndStores = False}) $ \partVal ->+       case partVal of+         LLVMMem.Err p -> do+           res <- checkSat bak p+           True @=? W4Sat.isUnsat res+         LLVMMem.NoErr p val -> assertFailure $ unlines+           [ "Reading from invalidated memory unexpectedly succeeded"+           , "Predicate: " ++ show p+           , "LLVM value read: " ++ show val+           ]++     -- Test with laxLoadsAndStores enabled, using both the+     -- StableSymbolic and UnstableSymbolic settings for+     -- indeterminateLoadBehavior. Here, reading from invalidated memory should succeed.+     testLaxInvalidatedRead "stable" LLVMMem.StableSymbolic+     testLaxInvalidatedRead "unstable" LLVMMem.UnstableSymbolic++-- | Test storing and retrieving pointer in an SMT-backed array memory model+testPointerStore :: T.TestTree+testPointerStore = testCase "pointer store" $ withMem LLVMD.BigEndian $ \bak mem0 -> do+  let sym = CB.backendGetSym bak+  -- Allocate two blocks+  sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024)+  (base_ptr1, _) <- LLVMMem.mallocRaw bak mem0 sz noAlignment+  (base_ptr2, block2_mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment++  -- Store the first base pointer in the second block+  let pointer_storage_type = LLVMMem.bitvectorType 8+  let base_ptr1_val = LLVMMem.ptrToPtrVal base_ptr1+  block2_mem2 <- LLVMMem.storeRaw bak+                                  block2_mem1+                                  base_ptr2+                                  pointer_storage_type+                                  noAlignment+                                  base_ptr1_val+  -- Read the pointer back+  base_ptr1_back <- LLVMMem.loadRaw sym+                                    block2_mem2+                                    base_ptr2+                                    pointer_storage_type+                                    noAlignment++  -- Assert that the read pointer is equal to the original pointer+  base_ptr1_back_safe <- LLVMMem.assertSafe bak base_ptr1_back+  is_equal <- LLVMMem.testEqual sym base_ptr1_val base_ptr1_back_safe+  case is_equal of+    Nothing -> assertFailure "testEqual failed"+    Just p -> do+      goal <- What4.notPred sym p+      res <- checkSat bak goal+      True @=? W4Sat.isUnsat res++-- | Test storing and retrieving a struct with and without 'laxLoadsAndStores'+-- enabled.+testStructStore :: T.TestTree+testStructStore = testCase "struct store" $ withMem LLVMD.BigEndian $ \bak mem0 ->+  do let sym = CB.backendGetSym bak+     sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 64+     let struct_storage_type = LLVMMem.mkStructType $ V.fromList+                                 [ (LLVMMem.bitvectorType 2, 2)+                                 , (LLVMMem.bitvectorType 4, 0)+                                 ]+     let w16 = knownNat @16+     let w32 = knownNat @32+     let struct_type_repr = Crucible.StructRepr $+                              Ctx.Empty Ctx.:>+                              LLVMMem.LLVMPointerRepr w16 Ctx.:>+                              LLVMMem.LLVMPointerRepr w32+     let struct_bv1 = BV.mkBV w16 27+     let struct_bv2 = BV.mkBV w32 42+     struct_sym_bv1 <- What4.bvLit sym w16 struct_bv1+     struct_sym_bv2 <- What4.bvLit sym w32 struct_bv2+     struct_field1 <- LLVMMem.llvmPointer_bv sym struct_sym_bv1+     struct_field2 <- LLVMMem.llvmPointer_bv sym struct_sym_bv2+     let struct_val = Ctx.Empty Ctx.:>+                      CS.RV struct_field1 Ctx.:>+                      CS.RV struct_field2++     let testWithOpts memOpts = do+           let ?memOpts = memOpts+           -- First, allocate some memory on the stack...+           (ptr, mem1) <- LLVMMem.doAlloca bak mem0 sz noAlignment "<alloca>"+           -- ...write a struct to it...+           mem2 <- LLVMMem.doStore bak mem1 ptr+                     struct_type_repr struct_storage_type+                     noAlignment struct_val+           -- ...read back the struct...+           struct_val' <- LLVMMem.doLoad bak mem2 ptr+                            struct_storage_type struct_type_repr noAlignment+           -- ...and finally, check that the struct read from memory is the+           -- same as the original struct.+           let checkField ::+                 forall w sym bak.+                 CB.IsSymBackend sym bak =>+                 bak ->+                 BV.BV w ->+                 CS.RegValue' sym (LLVMMem.LLVMPointerType w) ->+                 IO ()+               checkField bak' expectedBV actualPtrRV = do+                 actualSymBV <- projectLLVM_bv bak' $ CS.unRV actualPtrRV+                 Just expectedBV @=? What4.asBV actualSymBV+           checkField bak struct_bv1 (struct_val'^._1)+           checkField bak struct_bv2 (struct_val'^._2)++     testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = False })+     testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = True+                           , LLVMMem.indeterminateLoadBehavior = LLVMMem.StableSymbolic+                           })+     testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = True+                           , LLVMMem.indeterminateLoadBehavior = LLVMMem.UnstableSymbolic+                           })
+ test/TestTranslation.hs view
@@ -0,0 +1,62 @@+module TestTranslation+  (+    translationTests+  )+where++import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set++import qualified Test.Tasty as T+import           Test.Tasty.HUnit ( testCase, (@=?) )+import           Test.Tasty.QuickCheck ( testProperty )++import           Lang.Crucible.LLVM.Translation.Aliases ( reverseAliases )+++translationTests :: T.TestTree+translationTests =+  T.testGroup "Translation"+  [+    T.testGroup "Aliases" $++     ------------- Tests for reverseAliases++      let evenAlias xs x =+            let s = Set.fromList (F.toList xs)+            in if even x && Set.member x s+               then Just (x `div` 2)+               else Nothing+          addTargets xs = xs <> fmap (`div` 2) (Seq.filter even xs)+      in+        [ testCase "reverseAliases: empty" $+            Map.empty @=?+              reverseAliases id (const Nothing) (Seq.empty :: Seq.Seq Int)++        , testProperty "reverseAliases: singleton" $ \x ->+            Map.singleton (x :: Int) Set.empty ==+              reverseAliases id (const Nothing) (Seq.singleton x)++        , -- The result should not depend on ordering+          testProperty "reverseAliases: reverse" $ \xs ->+            let -- no self-aliasing allowed+                xs' = addTargets (Seq.filter (/= 0) xs)+            in reverseAliases id (evenAlias xs) (xs' :: Seq.Seq Int) ==+                 reverseAliases id (evenAlias xs) (Seq.reverse xs')++        , -- Every item should appear exactly once+          testProperty "reverseAliases: xor" $ \xs ->+            let xs'    = addTargets (Seq.filter (/= 0) xs)+                result = reverseAliases id (evenAlias xs) (xs' :: Seq.Seq Int)+                keys   = Map.keysSet result+                values = Set.unions (Map.elems result)+                --+                xor True a = not a+                xor False a = a+                --+            in all (\x -> Set.member x keys `xor` Set.member x values) xs'+        ]++  ]
+ test/Tests.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams   #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase       #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Main where++-- Crucible+import           Lang.Crucible.FunctionHandle ( newHandleAllocator )++import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.Some+import           Data.Parameterized.NatRepr+import           Data.Parameterized.SymbolRepr ( SomeSym(SomeSym) )++-- LLVM+import qualified Text.LLVM.AST as L+import           Text.LLVM.AST (Module)+import           Data.LLVM.BitCode++-- Tasty+import           Test.Tasty+import           Test.Tasty.HUnit+import qualified Test.Tasty.Options as TO+import qualified Test.Tasty.Runners as TR+import qualified Test.Tasty.Sugar as TS++-- General+import           Control.Lens (view)+import           Control.Monad+import           Data.Either ( fromRight )+import           Data.Maybe ( catMaybes )+import           GHC.TypeLits+import qualified Data.Map.Strict as Map+import           Data.Proxy ( Proxy(..) )+import qualified System.Directory as Dir+import           System.Environment ( lookupEnv )+import           System.Exit ( ExitCode(..) )+import           System.FilePath ( (-<.>), splitExtension, splitFileName )+import qualified System.Process as Proc++-- Modules being tested+import           Lang.Crucible.LLVM.MemModel ( mkMemVar )+import           Lang.Crucible.LLVM.MemType+import           Lang.Crucible.LLVM.Translation++import           TestFunctions+import           TestGlobals+import           TestMemory+import           TestTranslation+++data LLVMAssembler (source :: Symbol) = LLVMAssembler String+  deriving (Eq, Show)++instance TO.IsOption (SomeSym LLVMAssembler) where+  defaultValue = SomeSym $ LLVMAssembler @"default" "llvm-as"+  parseValue = Just . SomeSym . LLVMAssembler @"option"+  optionName = pure "llvm-assembler"+  optionHelp = pure $ unwords ["The LLVM assembler to use on .ll files"+                              ,"(overrides the LLVM_AS environment variable,"+                              ,"default is \"llvm-as\")"]++data Clang (source :: Symbol) = Clang String+  deriving (Eq, Show)++instance TO.IsOption (SomeSym Clang) where+  defaultValue = SomeSym $ Clang @"default" "clang"+  parseValue = Just . SomeSym . Clang @"option"+  optionName = pure "clang"+  optionHelp = pure $ unwords ["The clang binary to use to compile C files"+                              ,"(overrides the CLANG environment variable,"+                              ,"default is \"clang\")"]++optionSource :: opt (source :: Symbol) -> Proxy source+optionSource _ = Proxy++doProc :: String -> [String] -> IO ProcResult+doProc !exe !args = do+  (exitCode, stdout, stderr) <- Proc.readProcessWithExitCode exe args ""+  pure $ (exitCodeToInt exitCode, stdout, stderr)+  where exitCodeToInt ExitSuccess     = 0+        exitCodeToInt (ExitFailure i) = i++type ProcResult = (Int, String, String)++assertProcSuccess :: String -> String -> ProcResult -> Assertion+assertProcSuccess msg file (exitCode, stdout, stderr) = do+  when (exitCode /= 0) $ do+    putStrLn $ msg ++ " " ++ file ++ " failure"+    putStrLn stdout+    putStrLn stderr+  exitCode == 0 @? msg ++ " " ++ file ++ " attempt failed with " ++ show exitCode+++-- | Compile a C file with clang, returning the exit code+compile :: Clang "executable" -> FilePath -> IO ProcResult+compile (Clang clang) !file = doProc clang ["-emit-llvm", "-g", "-O0", "-c", file]++-- | Assemble a ll file with llvm-as, returning the exit code+assemble :: LLVMAssembler "executable" -> FilePath -> FilePath -> IO ProcResult+assemble (LLVMAssembler llvm_as) !inputFile !outputFile =+  doProc llvm_as ["-o", outputFile, inputFile]++-- | Parse an LLVM bit-code file.+-- Mostly copied from crucible-c.+parseLLVM :: FilePath -> IO (Either String Module)+parseLLVM !file =+  parseBitCodeFromFile file >>=+    \case+      Left err -> pure $ Left $ "Couldn't parse LLVM bitcode from file"+                                ++ file ++ "\n" ++ show err+      Right m  -> pure $ Right m++llvmTestIngredients :: [TR.Ingredient]+llvmTestIngredients = includingOptions [ TO.Option (Proxy @(SomeSym LLVMAssembler))+                                       , TO.Option (Proxy @(SomeSym Clang))+                                       ] :+                      includingOptions TS.sugarOptions :+                      TS.sugarIngredients [cCube, lCube] <>+                      defaultIngredients++cCube, lCube :: TS.CUBE+cCube = TS.mkCUBE { TS.inputDirs = ["test/c"]+                  , TS.rootName = "*.c"+                  , TS.separators = "."+                  , TS.expectedSuffix = "checks"+                  }++lCube = cCube { TS.inputDirs = ["test/ll"]+              , TS.rootName = "*.ll"+              }+++main :: IO ()+main = do+    do testSweets <- concat <$> (mapM TS.findSugar [cCube, lCube])++       fileTests <- TS.withSugarGroups testSweets testGroup $+           \sweets _ expectation -> do+             -- The expected file contains a list of the tests to run+             -- on the LLVM translation.+             checklist <- lines <$> readFile (TS.expectedFile expectation)+             return $+               testBuildTranslation (TS.rootFile sweets) $+               (\getTrans -> testGroup "checks" $ map (transCheck getTrans) checklist)++       defaultMainWithIngredients llvmTestIngredients $+         testGroup "Tests"+         [ functionTests+         , globalTests+         , memoryTests+         , translationTests+         , testGroup "Input Files" $ fileTests+         ]++++testBuildTranslation :: FilePath -> (IO (Some ModuleTranslation) -> TestTree) -> [TestTree]+testBuildTranslation srcPath llvmTransTests =+  -- n.b. srcPath may be a relative path+  let (dName, srcName) = splitFileName srcPath+      (fName, ext) = splitExtension srcName+      bcPath = srcPath -<.> ".bc"+      (_, bcName) = splitFileName bcPath++      genBCName = case ext of+                    ".c" -> "compile " <> fName+                    ".ll" -> "assemble " <> fName+                    _ -> error $ "Cannot build LLVM bitcode file from a " ++ ext ++ " file"+      parseBCName = "parse " ++ fName ++ " bitcode"+      translateName = "translate " ++ fName++      c_compile =+        if (ext == ".c")+        then+          Just $ askOption $ \(SomeSym clangOption :: SomeSym Clang) ->+          testCase genBCName $ do+          clang <-+            let src = optionSource clangOption in+            case sameSymbol src (Proxy :: Proxy "option") of+              Just Refl -> let Clang c = clangOption in return $ Clang c+              _ -> case sameSymbol src (Proxy :: Proxy "default") of+                Just Refl -> maybe (Clang "clang") Clang <$> lookupEnv "CLANG"+                _ -> error $ "Unknown Clang specification type: " <> symbolVal src+          assertProcSuccess "compile" srcPath =<<+              Dir.withCurrentDirectory dName (compile clang srcName)+        else Nothing++      llvm_assemble =+        if (ext == ".ll")+        then Just $ askOption $ \(SomeSym assemblerOption :: SomeSym LLVMAssembler) ->+          testCase genBCName $ do+          llvm_as <-+            let src = optionSource assemblerOption in+            case sameSymbol src (Proxy :: Proxy "option") of+              Just Refl -> let LLVMAssembler a = assemblerOption+                           in return $ LLVMAssembler a+              _ -> case sameSymbol src (Proxy :: Proxy "default") of+                Just Refl -> maybe (LLVMAssembler "llvm-as") LLVMAssembler <$>+                             lookupEnv "LLVM_AS"+                _ -> error $ "Unknown LLVM Assembler specification type: " <> symbolVal src++          assertProcSuccess "assemble" srcPath =<<+            Dir.withCurrentDirectory dName (assemble llvm_as srcName bcName)+        else Nothing++      parse_bitcode =+        testCase parseBCName $+        parseLLVM bcPath >>= \case+          Left err -> do+            putStrLn $ "Failed to parse " ++ bcPath+            putStrLn err+            err @?= ""+          Right _ -> pure ()++      trans = do halloc <- newHandleAllocator+                 let ?transOpts = defaultTranslationOptions+                 memVar <- mkMemVar "buildTranslation_test_llvm_memory" halloc+                 m <- (translateModule halloc memVar =<<+                        (fromRight (error "parsing was already verified") <$> parseLLVM bcPath))+                 return m++      translate_bitcode =+        testCase translateName $ do+        trans >>= \(Some modTrans) ->+          not (null $ view modTransDefs modTrans) @? "Translation of " ++ bcPath ++ " was empty (failed?)"+++  in catMaybes+    [ c_compile+    , llvm_assemble+    , Just $ after AllSucceed genBCName     parse_bitcode+    , Just $ after AllSucceed parseBCName   translate_bitcode+    , Just $ after AllSucceed translateName (llvmTransTests trans)+    ]+++transCheck :: IO (Some ModuleTranslation) -> String -> TestTree+transCheck getTrans = \case++  "extern_int" ->+    testCase "valid global extern variable reference" $ do+    Some t <- getTrans+    Map.singleton (L.Symbol "extern_int") (Right (i32, Nothing)) @=?+      Map.map snd (view globalInitMap t)++  "x=42" ->+    testCase "valid global integer symbol reference" $ do+    Some t <- getTrans+    Map.singleton (L.Symbol "x") (Right $ (i32, Just $ IntConst (knownNat @32) (BV.mkBV knownNat 42))) @=?+      Map.map snd (view globalInitMap t)++  "z.xx=17" ->+    testCase "valid global struct field symbol reference" $ do+    Some t <- getTrans+    IntConst (knownNat @32) (BV.mkBV knownNat 17) @=?+      case snd <$> Map.lookup (L.Symbol "z") (view globalInitMap t) of+        Just (Right (_, Just (StructConst _ (x : _)))) -> x+        _ -> IntConst (knownNat @1) (BV.zero knownNat)++  "x uninitialized" ->+    testCase "valid global unitialized variable reference" $ do+    Some t <- getTrans+    Map.singleton (L.Symbol "x") (Right $ (i32, Just $ ZeroConst i32)) @=?+      Map.map snd (view globalInitMap t)++  -- We're really just checking that the translation succeeds without+  -- exceptions.+  "" -> testCase "no additional checks" $ return ()++  other -> testCase other $ assertFailure $ "Unknown check: " <> other