packages feed

crucible-llvm 0.7.1 → 0.10

raw patch · 55 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,106 @@+# 0.10 -- 2026-09-10++* Add support for GHC 9.12 (at 9.12.2) and bump from 9.10.1 to 9.10.3.+* **BREAKING:** Rename various bits associated with the "breakpoint"+  feature in accordance with renaming the feature to "cutpoint".+  In particular, `testBreakpointFunction` is now `testCutpointFunction`.+  Also, the family of LLVM symbols recognized now begins with `__cutpoint__`+  rather than `__breakpoint__`.+* Support LLVM 22.+* Remove `llvmOverride_declare :: Text.LLVM.AST.Declare` from `LLVMOverride`.++  * Add `Lang.Crucible.LLVM.Intrinsics.Declare` module.+  * Change functions in `Lang.Crucible.LLVM.Intrinsics` to work+    with `Lang.Crucible.LLVM.Intrinsics.Declare.Declare`s. To+    migrate, use `Lang.Crucible.LLVM.Intrinsics.Declare.fromLLVM`+    to translate `Text.LLVM.AST.Declare`s into+    `Lang.Crucible.LLVM.Intrinsics.Declare.Declare`s+  * `do_register_llvm_override` no longer does any mapping nor adaptation of+    types, use `Lang.Crucible.LLVM.Intrinsics.Cast.lowerLLVMOverride` for that.+  * Replace `build_llvm_override` with+    `Lang.Crucible.LLVM.Intrinsics.Cast.lowerLLVMOverride`.+  * Overhaul the API of `Lang.Crucible.LLVM.Intrinsics.Cast`.+  * Replace various fields of `LLVMOverride` with a `Declare`. To migrate:+    * Replace `llvmOverride_name` with `llvmOvSymbol`+    * Replace `llvmOverride_args` with `llvmOvArgs`+    * Replace `llvmOverride_ret` with `llvmOvRet`+* Support the `llvm.scmp.*` and `llvm.ucmp.*` three-way comparison intrinsics.+* Added `register_specific_llvm_overrides` to register overrides for a provided+  list of declarations and definitions rather than extracting them from a+  provided LLVM module.+* **BREAKING**: Changed `lookupMetadata` to take the new `llvm-pretty`-provided+  `UnnamedMdIdx` rather than the older simple `Int` value to refer to the index+  of the metadata to be looked up.+* **BREAKING**: `explainCex`, `concBadBehavior`, `concUB`, and `concPoison` now+  take a `FloatModeRepr` argument.+* Fix the semantics of the `fptoui` and `fptosi` instructions. These+  instructions now round towards zero (previously, they incorrectly rounded+  towards negative infinity), and they now report undefined behavior if the+  input does not fit in the return type.++# 0.9 -- 2026-01-29++* The `LLVM_Debug` data constructor for `LLVMStmt`, as well as the related+  `LLVM_Dbg` data type, have been removed.+* Remove `aggInfo` in favor of `aggregateAlignment`, a lens that retrieves an+  `Alignment` instead of a full `AlignInfo`. In practice, `aggInfo` would only+  ever contain a single size (`0`) in its `AlignInfo`, and the concept of+  "size" doesn't really apply to aggregate alignments in data layout strings,+  so this was simplified to just be an `Alignment` instead.+* Support simulating bitcode that uses features from LLVM 19, including+  [debug records](https://llvm.org/docs/RemoveDIsDebugInfo.html) and+  [`getelementptr`+  attributes](https://releases.llvm.org/19.1.0/docs/LangRef.html#id237).+* Support the `nneg` flag in `zext` and `uitofp` instructions. If `nneg` is+  set, then converting a negative argument will yield a poisoned result.+* Support the `nuw` and `nsw` flags in `trunc` instructions. If `nuw` or `nsw`+  is set, then performing a truncation that would result in unsigned or signed+  integer overflow, respectively, will yield a poisoned result.+* Support the `samesign` flag in `icmp` instructions. If `samesign` is set, then+  comparing two integers of different signs will yield a poisoned result.+* Support the `llvm.tan`, `llvm.a{sin,cos,tan}`, `llvm.{sin,cos,tan}h`, and+  `llvm.atan2` floating-point intrinsics.+* Add extremely limited support for representing `poison` constants. For more+  details on the extent to which `crucible-llvm` can reason about `poison`, see+  `doc/limitations.md`.++  As part of these changes:++  * `LLVMVal` now features an additional `LLVMValPoison` data constructor.+  * `LLVMExpr` now features an additional `PoisonExpr` data constructor.+  * `LLVMConst` now features an addition `PoisonConst` data constructor.+  * `LLVMExtensionExpr` now features `LLVM_Poison{BV,Float}` data constructors,+    which represent primitive `poison` values.+* Remove the `Eq LLVMConst` instance. This instance was inherently unreliable+  because it cannot easily compute a simple `True`-or-`False` answer in the+  presence of `undef` or `poison` values.+* Replace `Data.Dynamic.Dynamic` with `SomeFnHandle` in+  `MemModel.{doInstallHandle,doLookupHandle}`.+* Add pretty-printing functions for use with `Lang.Crucible.Types.ppTypeRepr`+  * `Lang.Crucible.LLVM.MemModel.ppLLVMIntrinsicTypes`+  * `Lang.Crucible.LLVM.MemModel.ppLLVMMemIntrinsicType`+  * `Lang.Crucible.LLVM.MemModel.Pointer.ppLLVMPointerIntrinsicType`+* Overrides for `memcmp`, `strcmp`, `strncmp`, `strnlen`, `strcpy`, `strdup`,+  and `strndup`, supported by new APIs in `Lang.Crucible.LLVM.MemModel.Strings`.++# 0.8.0 -- 2025-11-09++* `Lang.Crucible.LLVM.MemModel.{loadString,loadMaybeString,strLen}`+  should now be imported from `Lang.Crucible.LLVM.MemModel.Strings`.+* Two new functions for loading C-style null-terminated strings from+  LLVM memory were added to `Lang.Crucible.LLVM.MemModel.Strings`:+  `loadConcretelyNullTerminatedString` and `loadProvablyNullTerminatedString`.+* Add a new "low-level" API for loading strings to+  `Lang.Crucible.LLVM.MemModel.Strings`: `ByteLoader`, `ByteChecker`, and+  `loadBytes`.+* Support simulating LLVM bitcode files whose data layout strings specify+  function pointer alignment.+* Fix a bug that would cause the simuator to compute incorrect results for the+  `llvm.is.fpclass` intrinsic. (Among other things, this is used to power the+  `isnan` function in Clang 17 or later.)+* Support vectorized versions of the `llvm.u{min,max}` and `llvm.s{min,max}`+  intrinsics.+ # 0.7.1 -- 2025-03-21  * Fix a bug in which the memory model would panic when attempting to unpack@@ -52,7 +155,7 @@   * `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.+  accommodate 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
crucible-llvm.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name:          crucible-llvm-Version:       0.7.1+Version:       0.10 Author:        Galois Inc. Copyright:     (c) Galois, Inc 2014-2022 Maintainer:    rscott@galois.com, kquick@galois.com, langston@galois.com@@ -29,24 +29,120 @@   ghc-prof-options: -O2 -fprof-auto-exported   default-language: Haskell2010 +common warns+  -- Specifying -Wall and -Werror can cause the project to fail to build on+  -- newer versions of GHC simply due to new warnings being added to -Wall. To+  -- prevent this from happening we manually list which warnings should be+  -- considered errors. We also list some warnings that are not in -Wall, though+  -- try to avoid "opinionated" warnings (though this judgement is clearly+  -- subjective).+  --+  -- Warnings are grouped by the GHC version that introduced them, and then+  -- alphabetically.+  --+  -- A list of warnings and the GHC version in which they were introduced is+  -- available here:+  -- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/using-warnings.html +  -- Since GHC 9.6 or earlier:+  ghc-options:+    -Wall+    -Werror=ambiguous-fields+    -Werror=deferred-type-errors+    -Werror=deprecated-flags+    -Werror=deprecations+    -Werror=deriving-defaults+    -Werror=deriving-typeable+    -Werror=dodgy-foreign-imports+    -Werror=duplicate-exports+    -Werror=empty-enumerations+    -Werror=gadt-mono-local-binds+    -Werror=identities+    -Werror=inaccessible-code+    -Werror=incomplete-patterns+    -Werror=incomplete-record-updates+    -Werror=incomplete-uni-patterns+    -Werror=inline-rule-shadowing+    -Werror=misplaced-pragmas+    -Werror=missed-extra-shared-lib+    -Werror=missing-exported-signatures+    -Werror=missing-fields+    -Werror=missing-home-modules+    -Werror=missing-methods+    -Werror=missing-pattern-synonym-signatures+    -Werror=missing-signatures+    -Werror=name-shadowing+    -Werror=noncanonical-monad-instances+    -Werror=noncanonical-monoid-instances+    -Werror=operator-whitespace+    -Werror=operator-whitespace-ext-conflict+    -Werror=orphans+    -Werror=overflowed-literals+    -Werror=overlapping-patterns+    -Werror=partial-fields+    -Werror=partial-type-signatures+    -Werror=redundant-bang-patterns+    -Werror=redundant-record-wildcards+    -Werror=redundant-strictness-flags+    -Werror=simplifiable-class-constraints+    -Werror=star-binder+    -Werror=star-is-type+    -Werror=tabs+    -Werror=type-defaults+    -Werror=typed-holes+    -Werror=type-equality-out-of-scope+    -Werror=type-equality-requires-operators+    -Werror=unicode-bidirectional-format-characters+    -Werror=unrecognised-pragmas+    -Werror=unrecognised-warning-flags+    -Werror=unsupported-calling-conventions+    -Werror=unsupported-llvm-version+    -Werror=unused-do-bind+    -Werror=unused-imports+    -Werror=unused-record-wildcards+    -Werror=warnings-deprecations+    -Werror=wrong-do-bind++  if impl(ghc < 9.8)+    ghc-options:+      -Werror=forall-identifier++  if impl(ghc >= 9.8)+    ghc-options:+      -Werror=incomplete-export-warnings+      -Werror=inconsistent-flags++  if impl(ghc >= 9.10)+    ghc-options:+      -Werror=badly-staged-types+      -Werror=data-kinds-tc+      -Werror=deprecated-type-abstractions+      -Werror=incomplete-record-selectors++  if impl(ghc < 9.12)+    ghc-options:+      -Werror=compat-unqualified-imports+ library   import: bldflags   build-depends:-    base >= 4.13 && < 4.20,+    base >= 4.13 && < 4.22,     attoparsec,     bv-sized >= 1.0.0,     bytestring,     containers >= 0.5.8.0,     crucible >= 0.5,     crucible-symio,-    what4 >= 0.4.1,+    what4 >= 0.5,     extra,-    lens,+    microlens,+    microlens-ghc,+    microlens-mtl,+    microlens-th,     itanium-abi >= 0.1.1.1 && < 0.2,-    llvm-pretty >= 0.12.1 && < 0.14,+    llvm-pretty >= 0.15.0.0 && < 0.16,     mtl,-    parameterized-utils >= 2.1.5 && < 2.2,+    parameterized-utils >= 2.3 && < 2.4,     pretty,     prettyprinter >= 1.7.0,     text,@@ -73,8 +169,10 @@     Lang.Crucible.LLVM.Extension     Lang.Crucible.LLVM.Functions     Lang.Crucible.LLVM.Globals+    Lang.Crucible.LLVM.Internal     Lang.Crucible.LLVM.Intrinsics     Lang.Crucible.LLVM.Intrinsics.Cast+    Lang.Crucible.LLVM.Intrinsics.Declare     Lang.Crucible.LLVM.Intrinsics.Libc     Lang.Crucible.LLVM.Intrinsics.LLVM     Lang.Crucible.LLVM.MalformedLLVMModule@@ -85,6 +183,7 @@     Lang.Crucible.LLVM.MemModel.MemLog     Lang.Crucible.LLVM.MemModel.Partial     Lang.Crucible.LLVM.MemModel.Pointer+    Lang.Crucible.LLVM.MemModel.Strings     Lang.Crucible.LLVM.MemType     Lang.Crucible.LLVM.PrettyPrint     Lang.Crucible.LLVM.Printf@@ -102,6 +201,10 @@     Lang.Crucible.LLVM.Extension.Arch     Lang.Crucible.LLVM.Extension.Syntax     Lang.Crucible.LLVM.Intrinsics.Common+    Lang.Crucible.LLVM.Intrinsics.Libc.Math+    Lang.Crucible.LLVM.Intrinsics.Libc.Stdio+    Lang.Crucible.LLVM.Intrinsics.Libc.Stdlib+    Lang.Crucible.LLVM.Intrinsics.Libc.String     Lang.Crucible.LLVM.Intrinsics.Libcxx     Lang.Crucible.LLVM.Intrinsics.Match     Lang.Crucible.LLVM.Intrinsics.Options@@ -124,10 +227,12 @@  test-suite crucible-llvm-tests   import: bldflags+  import: warns   type: exitcode-stdio-1.0   main-is: Tests.hs   hs-source-dirs: test   other-modules: MemSetup+               , TestBehavior                , TestFunctions                , TestGlobals                , TestMemory@@ -135,17 +240,20 @@   build-depends:     base,     bv-sized,+    bytestring,     containers,     crucible,     crucible-llvm,     directory,     filepath,-    lens,     llvm-pretty,     llvm-pretty-bc-parser,-    lens,+    microlens,+    oughta >= 0.3 && < 0.4,     parameterized-utils,     process,+    text,+    time,     what4,     tasty,     tasty-quickcheck,
src/Lang/Crucible/LLVM.hs view
@@ -28,9 +28,11 @@   , llvmExtensionImpl   ) where -import           Control.Lens import           Control.Monad (when) import           Control.Monad.IO.Class+import           Data.Function ((&))+import           Lens.Micro ((^.))+import           Lens.Micro.Mtl (use) import qualified Text.LLVM.AST as L  import           Lang.Crucible.Analysis.Postdom@@ -100,13 +102,13 @@ --   'registerLazyModuleFn' for a description. registerLazyModule ::    (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) =>-   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} ->+   (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling translation 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+-- | Lazily register the named function that is defined 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
src/Lang/Crucible/LLVM/Arch/X86.hs view
@@ -137,7 +137,7 @@  -- This is going to go away instance ShowFC ExtX86 where-  showFC _ _ = error "[ShowFC ExtX86] Not implmented."+  showFC _ _ = panic "ExtX86.showFC" ["Not implemented"]  instance TestEqualityFC ExtX86 where   testEqualityFC testSubterm =@@ -155,7 +155,7 @@  -- This is going away instance HashableFC ExtX86 where-  hashWithSaltFC _hash _s _x = error "[HashableFC ExtX86] Not implmented."+  hashWithSaltFC _hash _s _x = panic "ExtX86.hashWithSaltFC" ["Not implemented"]  instance FunctorFC ExtX86 where   fmapFC = fmapFCDefault@@ -167,7 +167,7 @@   traverseFC = $(U.structuralTraversal [t|ExtX86|] [])  instance PrettyApp ExtX86 where-  ppApp _pp _x = error "[PrettyApp ExtX86] XXX"+  ppApp _pp _x = panic "ExtX86.ppApp" ["Not implemented"]  instance TypeApp ExtX86 where   appType x =
src/Lang/Crucible/LLVM/ArraySizeProfile.hs view
@@ -31,12 +31,10 @@  , arraySizeProfile  ) where -import Control.Lens.TH--import Control.Lens--import Data.Type.Equality (testEquality)+import Data.Type.Equality (testEquality, (:~:)(Refl)) import Data.IORef+import Lens.Micro ((^.))+import Lens.Micro.TH (makeLenses) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Vector as Vector
src/Lang/Crucible/LLVM/DataLayout.hs view
@@ -38,17 +38,18 @@   , 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 Lens.Micro (Lens', lens, (^.))+import Lens.Micro.Mtl ((.=), (%=), (?=)) import Numeric.Natural+import qualified Text.LLVM as L  import What4.Utils.Arithmetic import Lang.Crucible.LLVM.Bytes+import Lang.Crucible.Panic (panic)   ------------------------------------------------------------------------@@ -131,14 +132,9 @@ 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+maxAlignmentInTree (AT t) = foldr max noAlignment (Map.elems t)  -- | Update alignment tree updateAlign :: Natural@@ -147,14 +143,10 @@             -> 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)+-- | Lens for accessing an alignment at a specific key in 'AlignInfo'.+atAlignInfo :: Natural -> Lens' AlignInfo (Maybe Alignment)+atAlignInfo k f m = updateAlign k m <$> f (findExact k m)+{-# INLINE atAlignInfo #-}  -- | Flags byte orientation of target machine. data EndianForm = BigEndian | LittleEndian@@ -164,12 +156,13 @@ data DataLayout    = DL { _intLayout :: EndianForm         , _stackAlignment :: !Alignment+        , _functionPtrAlignment :: !Alignment+        , _aggregateAlignment :: !Alignment         , _ptrSize     :: !Bytes         , _ptrAlign    :: !Alignment         , _integerInfo :: !AlignInfo         , _vectorInfo  :: !AlignInfo         , _floatInfo   :: !AlignInfo-        , _aggInfo     :: !AlignInfo         , _stackInfo   :: !AlignInfo         , _layoutWarnings :: [L.LayoutSpec]         }@@ -184,6 +177,14 @@ stackAlignment :: Lens' DataLayout Alignment stackAlignment = lens _stackAlignment (\s v -> s { _stackAlignment = v}) +functionPtrAlignment :: Lens' DataLayout Alignment+functionPtrAlignment =+  lens _functionPtrAlignment (\s v -> s { _functionPtrAlignment = v})++aggregateAlignment :: Lens' DataLayout Alignment+aggregateAlignment =+  lens _aggregateAlignment (\s v -> s { _aggregateAlignment = v})+ -- | Size of pointers in bytes. ptrSize :: Lens' DataLayout Bytes ptrSize = lens _ptrSize (\s v -> s { _ptrSize = v})@@ -201,10 +202,6 @@ 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})@@ -227,7 +224,7 @@  -- | Insert alignment into spec. setAt :: Lens' DataLayout AlignInfo -> Natural -> Alignment -> State DataLayout ()-setAt f sz a = f . at sz ?= a+setAt f sz a = f . atAlignInfo sz ?= a  -- | The default data layout if no spec is defined. From the LLVM -- Language Reference: "When constructing the data layout for a given@@ -238,12 +235,13 @@ defaultDataLayout = execState defaults dl   where dl = DL { _intLayout = BigEndian                 , _stackAlignment = noAlignment+                , _functionPtrAlignment = noAlignment                 , _ptrSize  = 8 -- 64 bit pointers = 8 bytes                 , _ptrAlign = Alignment 3 -- 64 bit alignment: 2^3=8 byte boundaries+                , _aggregateAlignment = noAlignment -- Aggregates are 1-byte aligned.                 , _integerInfo = emptyAlignInfo                 , _floatInfo   = emptyAlignInfo                 , _vectorInfo  = emptyAlignInfo-                , _aggInfo     = emptyAlignInfo                 , _stackInfo   = emptyAlignInfo                 , _layoutWarnings = []                 }@@ -262,34 +260,33 @@           -- 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^.functionPtrAlignment           , dl^.ptrAlign+          , dl^.aggregateAlignment           , 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."+fromSize i | i < 0 = panic "fromSize" ["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+setAtBits :: Lens' DataLayout AlignInfo -> L.LayoutSpec -> L.Storage -> State DataLayout ()+setAtBits f spec st =+  case fromBits (L.alignABI (L.storageAlignment st)) of     Left{} -> layoutWarnings %= (spec:)-    Right w -> f . at (fromSize sz) .= Just w+    Right w -> f . atAlignInfo (fromSize (L.storageSize st)) .= Just w  -- | Insert alignment into spec.-setBits :: Lens' DataLayout Alignment -> L.LayoutSpec -> Int -> State DataLayout ()+setBits :: Lens' DataLayout Alignment -> L.LayoutSpec -> L.NumBits -> State DataLayout () setBits f spec a =   case fromBits a of     Left{} -> layoutWarnings %= (spec:)@@ -302,27 +299,46 @@     case ls of       L.BigEndian    -> intLayout .= BigEndian       L.LittleEndian -> intLayout .= LittleEndian-      L.PointerSize n sz a _+      L.PointerSize ps            -- 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+        |  L.ptrAddrSpace ps == 0+        -> case fromBits (L.alignABI (L.storageAlignment st)) 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+       where st = L.ptrStorage ps+             (w,r) = L.storageSize st `divMod` 8+      L.IntegerSize st -> setStorageAlignInfo integerInfo st+      L.VectorSize st -> setStorageAlignInfo vectorInfo st+      L.FloatSize st -> setStorageAlignInfo floatInfo st+      L.StackObjSize st -> setStorageAlignInfo stackInfo st+      L.AggregateSize _ a -> setBits aggregateAlignment ls (L.alignABI a)       L.NativeIntSize _ -> return ()       L.StackAlign a    -> setBits stackAlignment ls a+      -- TODO: For now, we ignore the FunctionPointerAlignType field. This tells+      -- us whether the function pointer alignment is related to the alignment+      -- of functions, but llvm-pretty currently does not track the alignment of+      -- individual functions, so we have no use for this info just yet. When+      -- https://github.com/GaloisInc/llvm-pretty/issues/164 is implemented, we+      -- should revisit this.+      L.FunctionPointerAlign _ a -> setBits functionPtrAlignment ls a       L.Mangling _      -> return ()+      -- Currently, we assume that only the default address space (0) is used,+      -- and we ignore all other address space-related layout specs.+      -- See doc/limitations.md for more discussion.+      L.ProgramAddrSpace {} -> return ()+      L.GlobalAddrSpace {} -> return ()+      L.AllocaAddrSpace {} -> return ()+      L.NonIntegralPointerSpaces {} -> return ()+  where+    setStorageAlignInfo ::+      Lens' DataLayout AlignInfo -> L.Storage -> State DataLayout ()+    setStorageAlignInfo info st = setAtBits info ls st  -- | Create parsed data layout from layout spec AST. parseDataLayout :: L.DataLayout -> DataLayout
src/Lang/Crucible/LLVM/Errors.hs view
@@ -41,15 +41,14 @@  import           Prelude hiding (pred) -import           Control.Lens import           Data.Text (Text)- import           Data.Typeable (Typeable)+import           Lens.Micro (Lens', lens) import           GHC.Generics (Generic) import           Prettyprinter  import           What4.Interface-import           What4.Expr (GroundValue)+import           What4.Expr (ExprBuilder, Flags, FloatModeRepr, GroundValue)  import           Lang.Crucible.Simulator.RegValue (RegValue'(..)) import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME@@ -67,13 +66,16 @@  deriving Typeable  concBadBehavior ::-  IsExprBuilder sym =>+  ( IsExprBuilder sym+  , sym ~ ExprBuilder t st (Flags fm)+  ) =>   sym ->+  FloatModeRepr fm ->   (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) =+concBadBehavior sym fm conc (BBUndefinedBehavior ub) =+  BBUndefinedBehavior <$> UB.concUB sym fm conc ub+concBadBehavior sym _fm conc (BBMemoryError me) =   BBMemoryError <$> ME.concMemoryError sym conc me  -- -----------------------------------------------------------------------@@ -126,13 +128,13 @@ -- ----------------------------------------------------------------------- -- ** Lenses -classifier :: Simple Lens (LLVMSafetyAssertion sym) (BadBehavior sym)+classifier :: Lens' (LLVMSafetyAssertion sym) (BadBehavior sym) classifier = lens _classifier (\s v -> s { _classifier = v}) -predicate :: Simple Lens (LLVMSafetyAssertion sym) (Pred sym)+predicate :: Lens' (LLVMSafetyAssertion sym) (Pred sym) predicate = lens _predicate (\s v -> s { _predicate = v}) -extra :: Simple Lens (LLVMSafetyAssertion sym) (Maybe Text)+extra :: Lens' (LLVMSafetyAssertion sym) (Maybe Text) extra = lens _extra (\s v -> s { _extra = v})  explainBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann
src/Lang/Crucible/LLVM/Errors/MemoryError.hs view
@@ -6,6 +6,7 @@ -- Maintainer       : Langston Barrett <lbarrett@galois.com> -- Stability        : provisional --+-- See @crucible-llvm-cli/test-data/ub@ for tests demonstrating some of these. --------------------------------------------------------------------------  {-# LANGUAGE DataKinds #-}@@ -37,7 +38,6 @@  import           Data.Text (Text) import qualified Text.LLVM.AST as L-import           Type.Reflection (SomeTypeRep(SomeTypeRep)) import           Prettyprinter  import           What4.Interface@@ -99,7 +99,6 @@   = SymbolicPointer   | RawBitvector   | NoOverride-  | Uncallable SomeTypeRep   deriving (Eq, Ord)  ppFuncLookupError :: FuncLookupError -> Doc ann@@ -108,10 +107,6 @@     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
src/Lang/Crucible/LLVM/Errors/Poison.hs view
@@ -49,14 +49,16 @@ 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           Data.Parameterized.Classes (OrderingF(..), OrdF(..), 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)+import qualified What4.InterpretedFloatingPoint as W4IFP+import           What4.Expr (ExprBuilder, Flags, FloatModeRepr(..), GroundValue)+import qualified What4.Expr.GroundEval as W4GE  data Poison (e :: CrucibleType -> Type) where   -- | Arguments: @op1@, @op2@@@ -130,6 +132,34 @@   GEPOutOfBounds      :: (1 <= w, 1 <= wptr) => e (LLVMPointerType wptr)                       -> e (BVType w)                       -> Poison e+  ZExtNonNegative     :: (1 <= w)+                      => e (BVType w)+                      -> Poison e+  UiToFpNonNegative   :: (1 <= w)+                      => e (BVType w)+                      -> Poison e+  FpToUiNotRepresentable+                      :: (1 <= w)+                      => FloatInfoRepr fi+                      -> e (FloatType fi)+                      -> NatRepr w+                      -> Poison e+  FpToSiNotRepresentable+                      :: (1 <= w)+                      => FloatInfoRepr fi+                      -> e (FloatType fi)+                      -> NatRepr w+                      -> Poison e+  TruncNoUnsignedWrap :: (1 <= w)+                      => e (BVType w)+                      -> Poison e+  TruncNoSignedWrap   :: (1 <= w)+                      => e (BVType w)+                      -> Poison e+  ICmpSameSign        :: (1 <= w)+                      => e (BVType w)+                      -> e (BVType w)+                      -> Poison e   deriving (Typeable)  standard :: Poison e -> Standard@@ -154,6 +184,13 @@     InsertElementIndex _    -> LLVMRef LLVM8     LLVMAbsIntMin _         -> LLVMRef LLVM12     GEPOutOfBounds _ _      -> LLVMRef LLVM8+    ZExtNonNegative _       -> LLVMRef LLVM18+    UiToFpNonNegative _     -> LLVMRef LLVM19+    FpToUiNotRepresentable _ _ _ -> LLVMRef LLVM8+    FpToSiNotRepresentable _ _ _ -> LLVMRef LLVM8+    TruncNoUnsignedWrap _   -> LLVMRef LLVM20+    TruncNoSignedWrap _     -> LLVMRef LLVM20+    ICmpSameSign _ _        -> LLVMRef LLVM20  -- | Which section(s) of the document state that this is poison? cite :: Poison e -> Doc ann@@ -178,6 +215,13 @@     InsertElementIndex _    -> "‘insertelement’ Instruction (Semantics)"     LLVMAbsIntMin _         -> "‘llvm.abs.*’ Intrinsic (Semantics)"     GEPOutOfBounds _ _      -> "‘getelementptr’ Instruction (Semantics)"+    ZExtNonNegative _       -> "‘zext’ Instruction (Semantics)"+    UiToFpNonNegative _     -> "‘uitofp’ Instruction (Semantics)"+    FpToUiNotRepresentable _ _ _ -> "‘fptoui’ Instruction (Semantics)"+    FpToSiNotRepresentable _ _ _ -> "‘fptosi’ Instruction (Semantics)"+    TruncNoUnsignedWrap _   -> "‘trunc’ Instruction (Semantics)"+    TruncNoSignedWrap _     -> "‘trunc’ Instruction (Semantics)"+    ICmpSameSign _ _        -> "‘icmp’ Instruction (Semantics)"  explain :: Poison e -> Doc ann explain =@@ -226,13 +270,32 @@       ]      -- The following explanation is a bit unsatisfactory, because it is specific-    -- to how we treat this instruction in Crucible.+    -- to how we treat this instruction in Crucible. (See also #1605.)     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."+      , "treats all GEP instructions as if they had the `inbounds` attribute set."       ] +    ZExtNonNegative _ ->+      "A negative integer was zero-extended even though the `nneg` flag was set"+    UiToFpNonNegative _ ->+      "A negative integer was converted to a floating-point value even though the `nneg` flag was set"+    FpToUiNotRepresentable _ _ _ -> cat $+      [ "A floating-point value was converted to an unsigned integer,"+      , "even though the value does not fit in the unsigned integer's type"+      ]+    FpToSiNotRepresentable _ _ _ -> cat $+      [ "A floating-point value was converted to a signed integer,"+      , "even though the value does not fit in the signed integer's type"+      ]+    TruncNoUnsignedWrap _ ->+      "Unsigned truncation caused wrapping even though the `nuw` flag was set"+    TruncNoSignedWrap _ ->+      "Signed truncation caused wrapping even though the `nsw` flag was set"+    ICmpSameSign _ _ ->+      "Two integers with different signs were compared even though the `samesign` flag was set"+ details :: forall sym ann.   W4I.IsExpr (W4I.SymExpr sym) => Poison (RegValue' sym) -> [Doc ann] details =@@ -259,6 +322,21 @@       [ "Pointer:" <+> ppPtr ptr       , "Bitvector:" <+> W4I.printSymExpr bv       ]+    ZExtNonNegative v -> args [v]+    UiToFpNonNegative v -> args [v]+    FpToUiNotRepresentable fi (RV float) bvW ->+      [ "Floating-point type:" <+> pretty fi+      , "Floating-point value:" <+> W4I.printSymExpr float+      , "Unsigned integer size (in bits):" <+> viaShow bvW+      ]+    FpToSiNotRepresentable fi (RV float) bvW ->+      [ "Floating-point type:" <+> pretty fi+      , "Floating-point value:" <+> W4I.printSymExpr float+      , "Signed integer size (in bits):" <+> viaShow bvW+      ]+    TruncNoUnsignedWrap v -> args [v]+    TruncNoSignedWrap v -> args [v]+    ICmpSameSign v1 v2 -> args [v1, v2]   where  args :: forall w. [RegValue' sym (BVType w)] -> [Doc ann]@@ -287,14 +365,35 @@ ppReg = pp details  -- | Concretize a poison error message.-concPoison :: forall sym.-  W4I.IsExprBuilder sym =>+concPoison :: forall sym t st fm.+  ( W4I.IsExprBuilder sym+  , sym ~ ExprBuilder t st (Flags fm)+  ) =>   sym ->+  FloatModeRepr fm ->   (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) ->   Poison (RegValue' sym) -> IO (Poison (RegValue' sym))-concPoison sym conc poison =+concPoison sym fm 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+      bv (RV x) = RV <$> concBV sym conc x++      fp ::+        forall fi.+        FloatInfoRepr fi ->+        RegValue' sym (FloatType fi) ->+        IO (RegValue' sym (FloatType fi))+      fp fi (RV x) = do+        v <- conc x+        rv <-+          case fm of+            FloatIEEERepr ->+              W4I.floatLit sym (floatInfoToPrecisionRepr fi) v+            FloatUninterpretedRepr -> do+              sv <- W4GE.groundToSym sym (floatInfoToBVTypeRepr fi) v+              W4IFP.iFloatFromBinary sym fi sv+            FloatRealRepr ->+              W4IFP.iFloatLitRational sym fi v+        pure $ RV rv in   case poison of     AddNoUnsignedWrap v1 v2 ->       AddNoUnsignedWrap <$> bv v1 <*> bv v2@@ -334,6 +433,20 @@       GEPOutOfBounds <$> concPtr' sym conc p <*> bv v     LLVMAbsIntMin v ->       LLVMAbsIntMin <$> bv v+    ZExtNonNegative v ->+      ZExtNonNegative <$> bv v+    UiToFpNonNegative v ->+      UiToFpNonNegative <$> bv v+    FpToUiNotRepresentable v1 v2 v3 ->+      FpToUiNotRepresentable v1 <$> fp v1 v2 <*> pure v3+    FpToSiNotRepresentable v1 v2 v3 ->+      FpToSiNotRepresentable v1 <$> fp v1 v2 <*> pure v3+    TruncNoUnsignedWrap v ->+      TruncNoUnsignedWrap <$> bv v+    TruncNoSignedWrap v ->+      TruncNoSignedWrap <$> bv v+    ICmpSameSign v1 v2 ->+      ICmpSameSign <$> bv v1 <*> bv v2   -- -----------------------------------------------------------------------@@ -355,6 +468,8 @@            Nothing   -> Nothing    in $(U.structuralTypeEquality [t|Poison|]        [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |])+       , ( U.ConType [t| FloatInfoRepr |] `U.TypeApp` U.AnyType, [| testEquality |])+       , ( U.ConType [t| NatRepr |] `U.TypeApp` U.AnyType, [| testEquality |])        ])  ordcPoison :: forall e f.@@ -370,6 +485,8 @@     in $(U.structuralTypeOrd [t|Poison|]        [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |])+       , ( U.ConType [t| FloatInfoRepr |] `U.TypeApp` U.AnyType, [| compareF |])+       , ( U.ConType [t| NatRepr |] `U.TypeApp` U.AnyType, [| compareF |])        ])  instance TestEqualityC Poison where
src/Lang/Crucible/LLVM/Errors/Standards.hs view
@@ -69,6 +69,9 @@   | LLVM7   | LLVM8   | LLVM12+  | LLVM18+  | LLVM19+  | LLVM20   deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)  ppLLVMRefVer :: LLVMRefVer -> Text@@ -79,6 +82,9 @@ ppLLVMRefVer LLVM7  = "7" ppLLVMRefVer LLVM8  = "8" ppLLVMRefVer LLVM12 = "12"+ppLLVMRefVer LLVM18 = "18"+ppLLVMRefVer LLVM19 = "19"+ppLLVMRefVer LLVM20 = "20"  stdURL :: Standard -> Maybe Text stdURL (CStd   C11)     = Just "http://www.iso-9899.info/n1570.html"@@ -90,6 +96,9 @@ 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 (LLVMRef LLVM18) = Just "https://releases.llvm.org/18.1.0/docs/LangRef.html"+stdURL (LLVMRef LLVM19) = Just "https://releases.llvm.org/19.1.0/docs/LangRef.html"+stdURL (LLVMRef LLVM20) = Just "https://releases.llvm.org/20.1.0/docs/LangRef.html" stdURL _                = Nothing  ppStd :: Standard -> Text
src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs view
@@ -20,6 +20,8 @@ -- code essentially have an additional hypothesis: that the LLVM -- compiler/hardware platform behave identically to Crucible's simulator when -- encountering such behavior.+--+-- See @crucible-llvm-cli/test-data/ub@ for tests demonstrating some of these. --------------------------------------------------------------------------  {-# LANGUAGE DataKinds #-}@@ -69,7 +71,7 @@ import qualified Data.Parameterized.TraversableF as TF  import qualified What4.Interface as W4I-import           What4.Expr (GroundValue)+import           What4.Expr (ExprBuilder, Flags, FloatModeRepr, GroundValue)  import           Lang.Crucible.Types import           Lang.Crucible.Simulator.RegValue (RegValue'(..))@@ -558,12 +560,15 @@      ) subterms  -concUB :: forall sym.-  W4I.IsExprBuilder sym =>+concUB :: forall sym t st fm.+  ( W4I.IsExprBuilder sym+  , sym ~ ExprBuilder t st (Flags fm)+  ) =>   sym ->+  FloatModeRepr fm ->   (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) ->   UndefinedBehavior (RegValue' sym) -> IO (UndefinedBehavior (RegValue' sym))-concUB sym conc ub =+concUB sym fm 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@@ -612,4 +617,4 @@       AbsIntMin <$> bv v      PoisonValueCreated poison ->-      PoisonValueCreated <$> Poison.concPoison sym conc poison+      PoisonValueCreated <$> Poison.concPoison sym fm conc poison
src/Lang/Crucible/LLVM/Eval.hs view
@@ -7,10 +7,11 @@   , callStackFromMemVar   ) where -import           Control.Lens ((^.), view) import           Control.Monad (forM_) import qualified Data.List.NonEmpty as NE import           Data.Parameterized.TraversableF+import           Lens.Micro ((^.))+import           Lens.Micro.Extras (view)  import           What4.Interface @@ -23,6 +24,7 @@ import           Lang.Crucible.Simulator.Evaluation import           Lang.Crucible.Simulator.RegValue import           Lang.Crucible.Simulator.SimError+import           Lang.Crucible.Types (TypeRepr(..)) import           Lang.Crucible.Panic (panic)  import qualified Lang.Crucible.LLVM.Arch.X86 as X86@@ -99,3 +101,14 @@          blk <- natIte sym cond xblk yblk          off <- bvIte sym cond xoff yoff          return (LLVMPointer blk off)++    -- These are not necessarily considered correct, see crucible#366+    LLVM_PoisonBV w -> poisonPanic (BVRepr w)+    LLVM_PoisonFloat fi -> poisonPanic (FloatRepr fi)+  where+    poisonPanic tpr =+      panic+        "llvmExtensionEval"+        [ "Attempting to evaluate poison value"+        , "Type: " ++ show tpr+        ]
src/Lang/Crucible/LLVM/Extension/Syntax.hs view
@@ -98,7 +98,18 @@     !(f BoolType) -> !(f (LLVMPointerType w)) -> !(f (LLVMPointerType w)) ->     LLVMExtensionExpr f (LLVMPointerType w) +  -- | A @poison@ bitvector value. The semantics of this construct are still+  -- under discussion, see crucible#366.+  LLVM_PoisonBV ::+    (1 <= w) => !(NatRepr w) ->+    LLVMExtensionExpr f (BVType w) +  -- | A @poison@ float value. The semantics of this construct are still under+  -- discussion, see crucible#366.+  LLVM_PoisonFloat ::+    !(FloatInfoRepr fi) ->+    LLVMExtensionExpr f (FloatType fi)+ -- | 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@@ -230,43 +241,6 @@      !(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@@ -278,6 +252,8 @@       LLVM_PointerBlock _ _  -> NatRepr       LLVM_PointerOffset w _ -> BVRepr w       LLVM_PointerIte w _ _ _ -> LLVMPointerRepr w+      LLVM_PoisonBV w -> BVRepr w+      LLVM_PoisonFloat fi -> FloatRepr fi  instance PrettyApp LLVMExtensionExpr where   ppApp pp e =@@ -293,11 +269,16 @@         pretty "pointerOffset" <+> pp ptr       LLVM_PointerIte _ cond x y ->         pretty "pointerIte" <+> pp cond <+> pp x <+> pp y+      LLVM_PoisonBV _ ->+        pretty "poisonBV"+      LLVM_PoisonFloat _ ->+        pretty "poisonFloat"  instance TestEqualityFC LLVMExtensionExpr where   testEqualityFC testSubterm =     $(U.structuralTypeEquality [t|LLVMExtensionExpr|]        [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+       , (U.ConType [t|FloatInfoRepr|] `U.TypeApp` U.AnyType, [|testEquality|])        , (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|])@@ -311,6 +292,7 @@   compareFC testSubterm =     $(U.structuralTypeOrd [t|LLVMExtensionExpr|]        [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|])+       , (U.ConType [t|FloatInfoRepr|] `U.TypeApp` U.AnyType, [|compareF|])        , (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|])@@ -357,7 +339,6 @@     LLVM_PtrLe{} -> knownRepr     LLVM_PtrAddOffset w _ _ _ -> LLVMPointerRepr w     LLVM_PtrSubtract w _ _ _ -> BVRepr w-    LLVM_Debug{} -> knownRepr  instance PrettyApp LLVMStmt where   ppApp pp = \case@@ -385,14 +366,7 @@        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@@ -401,26 +375,6 @@ 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|]@@ -429,7 +383,6 @@        ,(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@@ -440,7 +393,6 @@        ,(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@@ -451,6 +403,4 @@  instance TraversableFC LLVMStmt where   traverseFC =-    $(U.structuralTraversal [t|LLVMStmt|]-      [(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|traverseFC|])-      ])+    $(U.structuralTraversal [t|LLVMStmt|] [])
src/Lang/Crucible/LLVM/Functions.hs view
@@ -55,12 +55,12 @@   , bindLLVMFunc   ) where -import           Control.Lens (use) import           Control.Monad (foldM) import           Control.Monad.IO.Class (liftIO) import qualified Data.Map as Map import qualified Data.Set as Set import           qualified Data.Text as Text+import           Lens.Micro.Mtl (use)  import qualified Text.LLVM.AST as L
src/Lang/Crucible/LLVM/Globals.hs view
@@ -45,8 +45,8 @@ import           Control.Monad (foldM) import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Except (MonadError(..))-import           Control.Lens hiding (op, (:>) )-import           Data.List (foldl', genericLength, isPrefixOf)+import qualified Data.Foldable as Foldable+import           Data.List (genericLength, isPrefixOf) import           Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set@@ -54,11 +54,11 @@ import           Control.Monad.State (StateT, runStateT, get, put) import           Data.Maybe (fromMaybe) import qualified Data.Parameterized.Context as Ctx+import           Data.Parameterized.NatRepr as NatRepr+import           Lens.Micro ((^.))  import qualified Text.LLVM.AST as L -import           Data.Parameterized.NatRepr as NatRepr- import           Lang.Crucible.LLVM.Bytes import           Lang.Crucible.LLVM.DataLayout import           Lang.Crucible.LLVM.Functions (allocLLVMFunPtrs)@@ -107,7 +107,7 @@               => LLVMContext arch               -> L.Module               -> GlobalInitializerMap-makeGlobalMap ctx m = foldl' addAliases globalMap1 (Map.toList (llvmGlobalAliases ctx))+makeGlobalMap ctx m = Foldable.foldl' addAliases globalMap1 (Map.toList (llvmGlobalAliases ctx))    where    addAliases mp (glob, aliases) =@@ -433,8 +433,8 @@     basicBlockConstInits bb = foldMap stmtConstInits (L.bbStmts bb)      stmtConstInits :: L.Stmt -> LoadRelConstInitMap-    stmtConstInits (L.Result _ instr _) = instrConstInits instr-    stmtConstInits (L.Effect instr _)   = instrConstInits instr+    stmtConstInits (L.Result _ instr _ _) = instrConstInits instr+    stmtConstInits (L.Effect instr _ _)   = instrConstInits instr      instrConstInits :: L.Instr -> LoadRelConstInitMap     instrConstInits (L.Call _ _ (L.ValSymbol fun) [ptr, _offset])@@ -482,7 +482,8 @@     foldLoadRelConstInitElem :: L.Global -> L.Value -> Maybe L.Value     foldLoadRelConstInitElem global constInitElem       | L.ValConstExpr-          (L.ConstConv L.Trunc+          (L.ConstConv+            (L.Trunc False False)             (L.Typed { L.typedValue =               L.ValConstExpr                 (L.ConstArith
+ src/Lang/Crucible/LLVM/Internal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++-- | Items in this module should /not/ be considered part of Crucible-LLVM's+-- API, they are exported only for the sake of the test suite.+module Lang.Crucible.LLVM.Internal+  ( assertionsEnabled+  ) where++import qualified Control.Exception as X+import           Data.Functor ((<&>))++-- | Check if assertions are enabled.+--+-- Note [Asserts]: When optimizations are enabled, GHC compiles 'X.assert' to+-- a no-op. However, Cabal enables @-O1@ by default. Therefore, if we want our+-- assertions to be checked by our test suite, we must carefully ensure that we+-- pass the correct flags to GHC for the @lib:crucible-llvm@ target. We verify+-- that we have done so by asserting as much in the test suite.+assertionsEnabled :: IO Bool+assertionsEnabled = do+  X.try @X.AssertionFailed (X.assert False (pure ())) <&>+    \case+      Left _ -> True+      Right () -> False
src/Lang/Crucible/LLVM/Intrinsics.hs view
@@ -24,17 +24,19 @@ , LLVMOverride(..)  , register_llvm_overrides+, register_specific_llvm_overrides , register_llvm_overrides_ , llvmDeclToFunHandleRepr+, declare_overrides  , module Lang.Crucible.LLVM.Intrinsics.Common , module Lang.Crucible.LLVM.Intrinsics.Options , module Lang.Crucible.LLVM.Intrinsics.Match ) where -import           Control.Lens hiding (op, (:>), Empty) import           Control.Monad (forM) import           Data.Maybe (catMaybes)+import           Lens.Micro ((^.)) import qualified Text.LLVM.AST as L  import qualified ABI.Itanium as ABI@@ -52,6 +54,8 @@ import           Lang.Crucible.LLVM.TypeContext (TypeContext)  import           Lang.Crucible.LLVM.Intrinsics.Common+import qualified Lang.Crucible.LLVM.Intrinsics.Cast as Cast+import qualified Lang.Crucible.LLVM.Intrinsics.Declare as Decl 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@@ -64,9 +68,22 @@    MapF.insert (knownSymbol :: SymbolRepr "LLVM_pointer") IntrinsicMuxFn $    MapF.empty --- | Match two sets of 'OverrideTemplate's against the @declare@s and @define@s+-- | Match two sets of 'OverrideTemplate's against the @Declare@s and @Define@s -- in a 'L.Module', registering all the overrides that apply and returning them--- as a list.+-- as a list.  There are internal pre-determined overrides that will be applied,+-- as well as any additional overrides supplied by the user (internal overrides+-- will supercede user overrides).+--+-- The "define" overrides are applied to *both* the @Define@s and @Declare@s+-- elements found within a module.+--+-- The "declare" overrides are applied only to the @Declare@s found within a+-- module.  The intent is that these overrides should only apply to @Declare@s,+-- whereas the "define" overrides should apply to any matching symbol in the LLVM+-- @Module@.+--+-- If both lists specify an override that matches a declare, the declare override+-- takes precedence over the define override. register_llvm_overrides ::   ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch   , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>@@ -79,8 +96,38 @@ register_llvm_overrides llvmModule defineOvrs declareOvrs llvmctx =   do defOvs <- register_llvm_define_overrides llvmModule defineOvrs llvmctx      declOvs <- register_llvm_declare_overrides llvmModule declareOvrs llvmctx-     pure (defOvs,  declOvs)+     pure (defOvs, declOvs) ++-- | Match a set of 'OverrideTemplate's against a provided set of definitions and+-- declarations, registering all the overrides that apply and returning them as a+-- pair of lists: the registered definition overrides and the registered+-- declaration overrides.+--+-- This is an alternative entrypoint for registering overrides.  The+-- functionality here is largely the same as 'register_llvm_overrides' except the+-- list of declares and defines are provided manually by the caller instead of+-- being extracted from the LLVM @Module@.+register_specific_llvm_overrides ::+  IsSymInterface sym =>+  HasLLVMAnn sym =>+  HasPtrWidth wptr =>+  wptr ~ ArchWidth arch =>+  (?intrinsicsOpts :: IntrinsicsOptions) =>+  (?memOpts :: MemOptions) =>+  [L.Define] ->+  [L.Declare] ->+  [OverrideTemplate p sym LLVM arch] {- ^ Additional \"define\" overrides -} ->+  [OverrideTemplate p sym LLVM arch] {- ^ Additional \"declare\" overrides -} ->+  LLVMContext arch ->+  OverrideSim p sym LLVM rtp l a ( [SomeLLVMOverride p sym LLVM] -- ^ def overrides+                                 , [SomeLLVMOverride p sym LLVM] -- ^ decl overrides+                                 )+register_specific_llvm_overrides defs decls addlDefOvrs addlDeclOvrs llvmctx =+  (,)+  <$> register_overrides (declareFromDefine <$> defs) addlDefOvrs llvmctx+  <*> register_overrides decls addlDeclOvrs 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.@@ -90,10 +137,11 @@ -- and the structure of C++ demangled names to extract more information. filterTemplates ::   [OverrideTemplate p sym ext arch] ->-  L.Declare ->+  Decl.SomeDeclare ->   [OverrideTemplate p sym ext arch]-filterTemplates ts decl = filter (matches nm . overrideTemplateMatcher) ts- where L.Symbol nm = L.decName decl+filterTemplates ts (Decl.SomeDeclare decl) =+  filter (matches nm . overrideTemplateMatcher) ts+  where L.Symbol nm = Decl.decName decl  -- | Match a set of 'OverrideTemplate's against a single 'L.Declare', -- registering all the overrides that apply and returning them as a list.@@ -103,16 +151,17 @@   -- | Overrides to attempt to match against this declaration   [OverrideTemplate p sym ext arch] ->   -- | Declaration of the function that might get overridden-  L.Declare ->+  Decl.SomeDeclare ->   OverrideSim p sym ext rtp l a [SomeLLVMOverride p sym ext]-match_llvm_overrides llvmctx acts decl =+match_llvm_overrides llvmctx acts someDecl =   llvmPtrWidth llvmctx $ \wptr -> withPtrWidth wptr $ do-    let acts' = filterTemplates acts decl-    let L.Symbol nm = L.decName decl+    let acts' = filterTemplates acts someDecl+    Decl.SomeDeclare decl <- pure someDecl+    let L.Symbol nm = Decl.decName decl     let declnm = either (const Nothing) Just $ ABI.demangleName nm     mbOvs <-       forM (map overrideTemplateAction acts') $ \(MakeOverride act) ->-        case act decl declnm llvmctx of+        case act someDecl declnm llvmctx of           Nothing -> pure Nothing           Just sov@(SomeLLVMOverride ov) -> do             register_llvm_override ov decl llvmctx@@ -127,30 +176,32 @@   -- | Overrides to attempt to match against these declarations   [OverrideTemplate p sym ext arch] ->   -- | Declarations of the functions that might get overridden-  [L.Declare] ->+  [Decl.SomeDeclare] ->   OverrideSim p sym ext rtp l a [SomeLLVMOverride p sym ext] register_llvm_overrides_ llvmctx acts decls =   concat <$> forM decls (\decl -> match_llvm_overrides llvmctx acts decl)  -- | Match a set of 'OverrideTemplate's against all the @declare@s and @define@s -- in a 'L.Module', registering all the overrides that apply and returning them--- as a list.+-- as a list.  This should apply the override regardless of whether the override+-- applies to a @Define@ or a @Declare@. -- -- Registers a default set of overrides, in addition to the ones passed as an -- argument. register_llvm_define_overrides ::-  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) =>+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch+  , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>   L.Module ->   -- | Additional (non-default) @define@ overrides   [OverrideTemplate p sym LLVM arch] ->   LLVMContext arch ->   OverrideSim p sym LLVM rtp l a [SomeLLVMOverride p sym LLVM] register_llvm_define_overrides llvmModule addlOvrs llvmctx =-  let ?lc = llvmctx^.llvmTypeCtx in-  register_llvm_overrides_ llvmctx (addlOvrs ++ define_overrides) $-     (allModuleDeclares llvmModule)+  let ?lc = llvmctx^.llvmTypeCtx+  in register_overrides (allModuleDeclares llvmModule) (addlOvrs ++ define_overrides)+     llvmctx --- | Match a set of 'OverrideTemplate's against all the @declare@s in a+-- | Match a set of 'OverrideTemplate's against all the @Declare@s in a -- 'L.Module', registering all the overrides that apply and returning them as -- a list. --@@ -166,9 +217,23 @@   OverrideSim p sym LLVM rtp l a [SomeLLVMOverride p sym LLVM] register_llvm_declare_overrides llvmModule addlOvrs llvmctx =   let ?lc = llvmctx^.llvmTypeCtx-  in register_llvm_overrides_ llvmctx (addlOvrs ++ declare_overrides) $-       L.modDeclares llvmModule+  in register_overrides (L.modDeclares llvmModule) (addlOvrs ++ declare_overrides)+     llvmctx +register_overrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch+  , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  [L.Declare] ->+  -- | Additional (non-default) @declare@ overrides+  [OverrideTemplate p sym LLVM arch] ->+  LLVMContext arch ->+  OverrideSim p sym LLVM rtp l a [SomeLLVMOverride p sym LLVM]+register_overrides llvmDecls ovrs llvmctx = do+  let ?lc = llvmctx^.llvmTypeCtx+  decls <- Decl.fromLLVMWithWarnings llvmDecls+  let ovs = map Cast.lowerOverrideTemplate ovrs+  register_llvm_overrides_ llvmctx ovs decls+ -- | Register overrides for declared-but-not-defined functions declare_overrides ::   ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch@@ -180,6 +245,7 @@   , map (\(SomeLLVMOverride ov) -> basic_llvm_override ov) LLVM.basic_llvm_overrides   , map (\(pfx, LLVM.Poly1LLVMOverride ov) -> polymorphic1_llvm_override pfx ov) LLVM.poly1_llvm_overrides   , map (\(pfx, LLVM.Poly1VecLLVMOverride ov) -> polymorphic1_vec_llvm_override pfx ov) LLVM.poly1_vec_llvm_overrides+  , map (\(pfx, LLVM.PolyCmpLLVMOverride ov) -> polymorphic_cmp_llvm_override pfx ov) LLVM.poly_cmp_llvm_overrides    -- C++ standard library functions   , [ Libcxx.register_cpp_override Libcxx.endlOverride ]
src/Lang/Crucible/LLVM/Intrinsics/Cast.hs view
@@ -1,133 +1,385 @@ -- | -- Module           : Lang.Crucible.LLVM.Intrinsics.Cast--- Description      : Cast between bitvectors and pointers in signatures--- Copyright        : (c) Galois, Inc 2024+-- Description      : Casting to and from the Crucible-LLVM ABI+-- Copyright        : (c) Galois, Inc 2026 -- License          : BSD3 -- Maintainer       : Langston Barrett <langston@galois.com> -- Stability        : provisional ----- The built-in overrides in "Lang.Crucible.LLVM.Intrinsics.Libc" and--- "Lang.Crucible.LLVM.Intrinsics.LLVM" frequently take arguments of type--- 'Lang.Crucible.Types.BVType', but at runtime everything is represented as an--- 'Lang.Crucible.LLVM.MemModel.Pointer.LLVMPtr'. This module contains helpers--- for \"casting\" between pointers and bitvectors.+-- In Crucible-LLVM, LLVM pointers and integers are translated to terms+-- of type 'Lang.Crucible.LLVM.MemModel.Pointer.LLVMPointerType'. When+-- writing overrides, it can be convenient to take arguments or return+-- values of 'Lang.Crucible.Types.BVType'. This is done frequently in+-- the built-in overrides in "Lang.Crucible.LLVM.Intrinsics.Libc" and+-- "Lang.Crucible.LLVM.Intrinsics.LLVM". This module contains helpers for+-- \"lowering\" signatures using Crucible bitvectors to ones that use LLVM+-- pointers. ------------------------------------------------------------------------ -{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Lang.Crucible.LLVM.Intrinsics.Cast-  ( ValCastError-  , printValCastError-  , ArgCast(applyArgCast)-  , ValCast(applyValCast)-  , castLLVMArgs-  , castLLVMRet+  ( -- * There+    CtxToLLVMType+  , ToLLVMType+  , ctxToLLVMType+  , toLLVMType+  , regValuesToLLVM+  , regValueToLLVM+    -- * Back again+  , regValuesFromLLVM+  , regValueFromLLVM+  , regEntriesFromLLVM+  , regMapFromLLVM+    -- * Lowering overrides+  , lowerLLVMOverride+  , lowerMakeOverride+  , lowerOverrideTemplate   ) where  import           Control.Monad.IO.Class (liftIO)-import           Control.Lens+import           Data.Coerce (coerce) import qualified Data.Text as Text+import           Data.Type.Equality ((:~:)(Refl), testEquality)  import qualified Data.Parameterized.Context as Ctx-import           Data.Parameterized.Some (Some(Some))-import           Data.Parameterized.TraversableFC (fmapFC)+import qualified Data.Parameterized.TraversableFC as TFC -import           What4.FunctionName (FunctionName (functionName))+import qualified What4.FunctionName as WFN -import           Lang.Crucible.Backend-import           Lang.Crucible.Simulator (SimErrorReason(AssertFailureSimError))-import           Lang.Crucible.Simulator.OverrideSim-import           Lang.Crucible.Simulator.RegMap-import           Lang.Crucible.Types+import qualified Lang.Crucible.Backend as CB+import           Lang.Crucible.Panic (panic)+import qualified Lang.Crucible.Simulator.OverrideSim as CSO+import qualified Lang.Crucible.Simulator.RegMap as CRM+import qualified Lang.Crucible.Simulator.RegValue as CRV+import qualified Lang.Crucible.Simulator.SimError as CSE+import qualified Lang.Crucible.Types as CT -import           Lang.Crucible.LLVM.MemModel.Partial (ptrToBv)-import           Lang.Crucible.LLVM.MemModel.Pointer+import qualified Lang.Crucible.LLVM.Intrinsics.Common as IC+import qualified Lang.Crucible.LLVM.Intrinsics.Declare as Decl+import           Lang.Crucible.LLVM.MemModel.Partial (HasLLVMAnn, ptrToBv)+import           Lang.Crucible.LLVM.MemModel.Pointer (LLVMPointerType)+import qualified Lang.Crucible.LLVM.MemModel.Pointer as Ptr -data ValCastError-  = -- | Mismatched number of arguments ('castLLVMArgs') or struct fields-    -- ('castLLVMRet').-    MismatchedShape-    -- | Can\'t cast between these types-  | ValCastError (Some TypeRepr) (Some TypeRepr)+---------------------------------------------------------------------+-- * There --- | Turn a 'ValCastError' into a human-readable message (lines).-printValCastError :: ValCastError -> [String]-printValCastError =+-- | Convert bitvectors to 'LLVMPointer's.+type CtxToLLVMType :: Ctx.Ctx CT.CrucibleType -> Ctx.Ctx CT.CrucibleType+type family CtxToLLVMType t where+  CtxToLLVMType Ctx.EmptyCtx = Ctx.EmptyCtx+  CtxToLLVMType (ctx Ctx.::> tp) = CtxToLLVMType ctx Ctx.::> ToLLVMType tp++-- | Convert bitvectors to 'LLVMPointer's.+type ToLLVMType :: CT.CrucibleType -> CT.CrucibleType+type family ToLLVMType t where+  ToLLVMType (CT.BVType w) = LLVMPointerType w++  -- recursive cases+  ToLLVMType (CT.VectorType tp) = CT.VectorType (ToLLVMType tp)+  ToLLVMType (CT.StructType ctx) = CT.StructType (CtxToLLVMType ctx)++  -- no-ops+  ToLLVMType CT.AnyType = CT.AnyType+  ToLLVMType CT.UnitType = CT.UnitType+  ToLLVMType CT.BoolType = CT.BoolType+  ToLLVMType CT.NatType = CT.NatType+  ToLLVMType CT.IntegerType = CT.IntegerType+  ToLLVMType CT.RealValType = CT.RealValType+  ToLLVMType (CT.FloatType flt) = CT.FloatType flt+  ToLLVMType (CT.IEEEFloatType ps) = CT.IEEEFloatType ps+  ToLLVMType CT.CharType = CT.CharType+  ToLLVMType (CT.StringType si) = CT.StringType si+  ToLLVMType (CT.ComplexRealType) = CT.ComplexRealType+  ToLLVMType (CT.IntrinsicType nm ctx) = CT.IntrinsicType nm ctx++  -- these shouldn't appear in override signaures, so don't worry about them+  ToLLVMType (CT.FunctionHandleType ctx ret) = CT.FunctionHandleType ctx ret+  ToLLVMType (CT.RecursiveType nm ctx) = CT.RecursiveType nm ctx+  ToLLVMType (CT.MaybeType tp) = CT.MaybeType tp+  ToLLVMType (CT.ReferenceType t) = CT.ReferenceType t+  ToLLVMType (CT.SequenceType tp) = CT.SequenceType tp+  ToLLVMType (CT.VariantType ctx) = CT.VariantType ctx+  ToLLVMType (CT.WordMapType n tp) = CT.WordMapType n tp+  ToLLVMType (CT.StringMapType tp) = CT.StringMapType tp+  ToLLVMType (CT.SymbolicArrayType idx t) = CT.SymbolicArrayType idx t+  ToLLVMType (CT.SymbolicStructType ctx) = CT.SymbolicStructType ctx++-- | Value-level analogue of 'CtxToLLVMType'+ctxToLLVMType ::+  Ctx.Assignment CT.TypeRepr ctx ->+  Ctx.Assignment CT.TypeRepr (CtxToLLVMType ctx)+ctxToLLVMType =   \case-    MismatchedShape -> ["argument shape mismatch"]-    ValCastError (Some ret) (Some ret') ->-      [ "Cannot cast types"-      , "*** Source type: " ++ show ret-      , "*** Target type: " ++ show ret'-      ]+    Ctx.Empty -> Ctx.empty+    ctx Ctx.:> t -> ctxToLLVMType ctx Ctx.:> toLLVMType t --- | A function to (infallibly) cast between 'Ctx.Assignment's of 'RegEntry's.-newtype ArgCast p sym ext args args' =-  ArgCast { applyArgCast :: (forall rtp l a.-    Ctx.Assignment (RegEntry sym) args ->-    OverrideSim p sym ext rtp l a (Ctx.Assignment (RegEntry sym) args')) }+-- | Value-level analogue of 'ToLLVMType'+toLLVMType ::+  CT.TypeRepr t ->+  CT.TypeRepr (ToLLVMType t)+toLLVMType =+  \case+    CT.BVRepr w -> Ptr.LLVMPointerRepr w --- | A function to (infallibly) cast a value of types @tp@ to @tp'@.-newtype ValCast p sym ext tp tp' =-  ValCast { applyValCast :: (forall rtp l a.-    RegValue sym tp ->-    OverrideSim p sym ext rtp l a (RegValue sym tp')) }+    -- recursive cases+    CT.VectorRepr tp -> CT.VectorRepr (toLLVMType tp)+    CT.StructRepr ctx -> CT.StructRepr (ctxToLLVMType ctx) --- | Attempt to construct a function to cast between 'Ctx.Assignment's of--- 'RegEntry's.-castLLVMArgs :: forall p sym ext bak args args'.-  IsSymBackend sym bak =>+    -- no-ops+    CT.AnyRepr -> CT.AnyRepr+    CT.UnitRepr -> CT.UnitRepr+    CT.BoolRepr -> CT.BoolRepr+    CT.NatRepr -> CT.NatRepr+    CT.IntegerRepr -> CT.IntegerRepr+    CT.RealValRepr -> CT.RealValRepr+    CT.FloatRepr flt -> CT.FloatRepr flt+    CT.IEEEFloatRepr ps -> CT.IEEEFloatRepr ps+    CT.CharRepr -> CT.CharRepr+    CT.StringRepr si -> CT.StringRepr si+    CT.ComplexRealRepr -> CT.ComplexRealRepr+    CT.IntrinsicRepr nm ctx -> CT.IntrinsicRepr nm ctx++    -- these shouldn't appear in override signaures, so don't worry about them+    t@CT.FunctionHandleRepr {} -> t+    t@CT.RecursiveRepr {} -> t+    t@CT.MaybeRepr {} -> t+    t@CT.SequenceRepr {} -> t+    t@CT.ReferenceRepr {} -> t+    t@CT.VariantRepr {} -> t+    t@CT.WordMapRepr {} -> t+    t@CT.StringMapRepr {} -> t+    t@CT.SymbolicArrayRepr {} -> t+    t@CT.SymbolicStructRepr {} -> t++-- | 'regValueToLLVM' over an 'Ctx.Assignment'+regValuesToLLVM ::+  CB.IsSymInterface sym =>+  sym ->+  Ctx.Assignment CT.TypeRepr tys ->+  Ctx.Assignment (CRV.RegValue' sym) tys ->+  IO (Ctx.Assignment  (CRV.RegValue' sym) (CtxToLLVMType tys))+regValuesToLLVM sym tys vals =+  case (tys, vals) of+    (Ctx.Empty, Ctx.Empty) -> pure Ctx.empty+    (restTys Ctx.:> ty, restVals Ctx.:> CRV.RV val) -> do+      rest <- regValuesToLLVM sym restTys restVals+      val' <- regValueToLLVM sym ty val+      pure (rest Ctx.:> CRV.RV val')++-- | Convert a 'CRV.RegValue' to its corresponding LLVM type (replacing+-- bitvectors with LLVM pointers).+regValueToLLVM ::+  CB.IsSymInterface sym =>+  sym ->+  CT.TypeRepr ty ->+  CRV.RegValue sym ty ->+  IO (CRV.RegValue sym (ToLLVMType ty))+regValueToLLVM sym ty val =+  case ty of+    CT.BVRepr {} -> Ptr.llvmPointer_bv sym val++    -- recursive cases+    CT.VectorRepr elemTy -> traverse (regValueToLLVM sym elemTy) val+    CT.StructRepr fieldTys -> regValuesToLLVM sym fieldTys val++    -- no-ops+    CT.AnyRepr -> pure val+    CT.UnitRepr -> pure val+    CT.BoolRepr -> pure val+    CT.NatRepr -> pure val+    CT.IntegerRepr -> pure val+    CT.RealValRepr -> pure val+    CT.FloatRepr {} -> pure val+    CT.IEEEFloatRepr {} -> pure val+    CT.CharRepr -> pure val+    CT.StringRepr {} -> pure val+    CT.ComplexRealRepr -> pure val+    CT.IntrinsicRepr {} -> pure val++    -- these shouldn't appear in override signaures, so don't worry about them+    CT.FunctionHandleRepr {} -> pure val+    CT.MaybeRepr {} -> pure val+    CT.SequenceRepr {} -> pure val+    CT.RecursiveRepr {} -> pure val+    CT.ReferenceRepr {} -> pure val+    CT.VariantRepr {} -> pure val+    CT.WordMapRepr {} -> pure val+    CT.StringMapRepr {} -> pure val+    CT.SymbolicArrayRepr {} -> pure val+    CT.SymbolicStructRepr {} -> pure val++---------------------------------------------------------------------+-- * Back again++-- | Map 'regValueFromLLVM' over an 'Ctx.Assignment'.+regValuesFromLLVM ::+  CB.IsSymBackend sym bak =>+  bak ->   -- | Only used in error messages-  FunctionName ->+  WFN.FunctionName ->+  Ctx.Assignment CT.TypeRepr tys ->+  Ctx.Assignment CT.TypeRepr (CtxToLLVMType tys) ->+  Ctx.Assignment (CRV.RegValue' sym) (CtxToLLVMType tys) ->+  IO (Ctx.Assignment (CRV.RegValue' sym) tys)+regValuesFromLLVM bak fNm wanteds tys vals =+  case (wanteds, tys) of+    (Ctx.Empty, Ctx.Empty) -> pure vals+    (restWanted Ctx.:> w, restTys Ctx.:> t) -> do+      case vals of+        rest Ctx.:> CRV.RV val -> do+          rest' <- regValuesFromLLVM bak fNm restWanted restTys rest+          val' <- regValueFromLLVM bak fNm w t val+          pure (rest' Ctx.:> CRV.RV val')++-- | Convert a 'CRV.RegValue' from its corresponding LLVM type (replacing LLVM+-- pointers with bitvectors where needed).+regValueFromLLVM ::+  forall sym bak ty.+  CB.IsSymBackend sym bak =>   bak ->-  CtxRepr args' ->-  CtxRepr args ->-  Either ValCastError (ArgCast p sym ext args args')-castLLVMArgs _fnm _ Ctx.Empty Ctx.Empty =-  Right (ArgCast (\_ -> return Ctx.Empty))-castLLVMArgs fnm bak (rest' Ctx.:> tp') (rest Ctx.:> tp) =-  do ValCast f  <- castLLVMRet fnm bak tp tp'-     ArgCast fs <- castLLVMArgs fnm bak rest' rest-     Right (ArgCast-              (\(xs Ctx.:> x) -> do-                    xs' <- fs xs-                    x'  <- f (regValue x)-                    pure (xs' Ctx.:> RegEntry tp' x')))-castLLVMArgs _ _ _ _ = Left MismatchedShape+  -- | Only used in error messages+  WFN.FunctionName ->+  CT.TypeRepr ty ->+  CT.TypeRepr (ToLLVMType ty) ->+  CRV.RegValue sym (ToLLVMType ty) ->+  IO (CRV.RegValue sym ty)+regValueFromLLVM bak fNm wanted ty val = do+  case (wanted, ty) of+    (CT.BVRepr w, Ptr.LLVMPointerRepr w')+      | Just Refl <- testEquality w w' -> do+        let err = +              CSE.AssertFailureSimError+               "Found a pointer where a bitvector was expected"+               ("In the arguments of "+                ++ Text.unpack (WFN.functionName fNm))+        ptrToBv bak err val+    (CT.BVRepr {}, _) ->+      panic+        "regValueFromLLVM"+        [ "Pointer and bitvector of different sizes related by ToLLVMType!"+        , "This is impossible by the definition of ToLLVMType."+        ] --- | Attempt to construct a function to cast values of type @ret@ to type--- @ret'@.-castLLVMRet ::-  IsSymBackend sym bak =>+    -- recursive cases++    (CT.VectorRepr wantedElemTy, CT.VectorRepr elemTy) ->+      traverse (regValueFromLLVM bak fNm wantedElemTy elemTy) val++    (CT.StructRepr wantedFieldTys, CT.StructRepr fieldTys) ->+      regValuesFromLLVM bak fNm wantedFieldTys fieldTys val++    -- no-ops++    (CT.AnyRepr, _) -> pure val+    (CT.UnitRepr, _) ->  pure val+    (CT.BoolRepr, _) ->  pure val+    (CT.NatRepr, _) -> pure val+    (CT.IntegerRepr, _) -> pure val+    (CT.RealValRepr, _) -> pure val+    (CT.CharRepr, _) -> pure val+    (CT.ComplexRealRepr, _) -> pure val+    (CT.FloatRepr {}, _) -> pure val+    (CT.IEEEFloatRepr {}, _) -> pure val+    (CT.StringRepr {}, _) -> pure val+    (CT.IntrinsicRepr {}, _) -> pure val++    -- these shouldn't appear in override signaures, so don't worry about them++    (CT.FunctionHandleRepr {}, _) -> pure val+    (CT.MaybeRepr {}, _) -> pure val+    (CT.SequenceRepr {}, _) -> pure val+    (CT.RecursiveRepr {}, _) -> pure val+    (CT.ReferenceRepr {}, _) -> pure val+    (CT.VariantRepr {}, _) -> pure val+    (CT.WordMapRepr {}, _) -> pure val+    (CT.StringMapRepr {}, _) -> pure val+    (CT.SymbolicArrayRepr {}, _) -> pure val+    (CT.SymbolicStructRepr {}, _) -> pure val++-- | Map 'regValueFromLLVM' over an 'Ctx.Assignment' of 'CRM.RegEntry's.+regEntriesFromLLVM ::+  CB.IsSymBackend sym bak =>+  bak ->   -- | Only used in error messages-  FunctionName ->+  WFN.FunctionName ->+  Ctx.Assignment CT.TypeRepr tys ->+  Ctx.Assignment CT.TypeRepr (CtxToLLVMType tys) ->+  Ctx.Assignment (CRM.RegEntry sym) (CtxToLLVMType tys) ->+  IO (Ctx.Assignment (CRM.RegEntry sym) tys)+regEntriesFromLLVM bak fNm wanteds tys vals = do+  let cast = regValuesFromLLVM bak fNm wanteds tys+  Ctx.zipWith (\ty (CRV.RV v) -> CRM.RegEntry ty v) wanteds+    <$> cast (TFC.fmapFC (\(CRM.RegEntry _ty v) -> CRM.RV v) vals)++-- | Map 'regValueFromLLVM' over a 'CRM.RegMap'.+regMapFromLLVM ::+  forall sym bak tys.+  CB.IsSymBackend sym bak =>   bak ->-  TypeRepr ret  ->-  TypeRepr ret' ->-  Either ValCastError (ValCast p sym ext ret ret')-castLLVMRet _fnm bak (BVRepr w) (LLVMPointerRepr w')-  | Just Refl <- testEquality w w'-  = Right (ValCast (liftIO . llvmPointer_bv (backendGetSym bak)))-castLLVMRet fnm bak (LLVMPointerRepr w) (BVRepr w')-  | Just Refl <- testEquality w w'-  = let err = -          AssertFailureSimError-           "Found a pointer where a bitvector was expected"-           ("In the arguments or return value of " ++ Text.unpack (functionName fnm)) in-    Right (ValCast (liftIO . ptrToBv bak err))-castLLVMRet fnm bak (VectorRepr tp) (VectorRepr tp')-  = do ValCast f <- castLLVMRet fnm bak tp tp'-       Right (ValCast (traverse f))-castLLVMRet fnm bak (StructRepr ctx) (StructRepr ctx')-  = do ArgCast tf <- castLLVMArgs fnm bak ctx' ctx-       Right (ValCast (\vals ->-          let vals' = Ctx.zipWith (\tp (RV v) -> RegEntry tp v) ctx vals in-          fmapFC (\x -> RV (regValue x)) <$> tf vals'))+  -- | Only used in error messages+  WFN.FunctionName ->+  Ctx.Assignment CT.TypeRepr tys ->+  Ctx.Assignment CT.TypeRepr (CtxToLLVMType tys) ->+  CRM.RegMap sym (CtxToLLVMType tys) ->+  IO (CRM.RegMap sym tys)+regMapFromLLVM bak fNm wanteds tys =+  coerce (regEntriesFromLLVM bak fNm wanteds tys) -castLLVMRet _fnm _bak ret ret'-  | Just Refl <- testEquality ret ret'-  = Right (ValCast return)-castLLVMRet _fnm _bak ret ret' = Left (ValCastError (Some ret) (Some ret'))+---------------------------------------------------------------------+-- * Lowering overrides++-- | Lower an override to use the Crucible-LLVM ABI.+lowerLLVMOverride ::+  forall p sym ext args ret.+  HasLLVMAnn sym =>+  IC.LLVMOverride p sym ext args ret ->+  IC.LLVMOverride p sym ext (CtxToLLVMType args) (ToLLVMType ret)+lowerLLVMOverride ov =+  IC.LLVMOverride+  { IC.llvmOvDecl =+      Decl.Declare+      { Decl.decName = IC.llvmOvSymbol ov +      , Decl.decArgs = argTys'+      , Decl.decRet = retTy'+      }+  , IC.llvmOvDefn =+    \mvar args ->+      CSO.ovrWithBackend $ \bak -> do+        let fNm = IC.llvmOvName ov+        args' <- liftIO (regEntriesFromLLVM bak fNm argTys argTys' args)+        ret <- IC.llvmOvDefn ov mvar args'+        liftIO (regValueToLLVM (CB.backendGetSym bak) retTy ret)+  }+  where+    argTys = IC.llvmOvArgs ov+    argTys' = ctxToLLVMType argTys+    retTy = IC.llvmOvRet ov+    retTy' = toLLVMType retTy++-- | Postcompose 'lowerLLVMOverride' with a 'IC.MakeOverride'+lowerMakeOverride ::+  HasLLVMAnn sym =>+  IC.MakeOverride p sym ext arch ->+  IC.MakeOverride p sym ext arch+lowerMakeOverride (IC.MakeOverride f) =+  IC.MakeOverride $ \decl nm ctx -> do+    IC.SomeLLVMOverride ov <- f decl nm ctx+    Just (IC.SomeLLVMOverride (lowerLLVMOverride ov))++-- | Call 'lowerLLVMOverride' on the override in a 'OverrideTemplate'+lowerOverrideTemplate ::+  HasLLVMAnn sym =>+  IC.OverrideTemplate p sym ext arch ->+  IC.OverrideTemplate p sym ext arch+lowerOverrideTemplate t =+  IC.OverrideTemplate+  { IC.overrideTemplateMatcher = IC.overrideTemplateMatcher t+  , IC.overrideTemplateAction = lowerMakeOverride (IC.overrideTemplateAction t)+  }
src/Lang/Crucible/LLVM/Intrinsics/Common.hs view
@@ -1,7 +1,7 @@ -- | -- Module           : Lang.Crucible.LLVM.Intrinsics.Common -- Description      : Types used in override definitions--- Copyright        : (c) Galois, Inc 2015-2019+-- Copyright        : (c) Galois, Inc 2015-2026 -- License          : BSD3 -- Maintainer       : Rob Dockins <rdockins@galois.com> -- Stability        : provisional@@ -19,7 +19,12 @@  module Lang.Crucible.LLVM.Intrinsics.Common   ( LLVMOverride(..)+  , llvmOvSymbol+  , llvmOvName+  , llvmOvArgs+  , llvmOvRet   , SomeLLVMOverride(..)+  , someLlvmOverrideDeclare   , MakeOverride(..)   , llvmSizeT   , llvmSSizeT@@ -29,8 +34,9 @@   , basic_llvm_override   , polymorphic1_llvm_override   , polymorphic1_vec_llvm_override+  , polymorphic_cmp_llvm_override -  , build_llvm_override+  , llvmOverrideToTypedOverride   , register_llvm_override   , register_1arg_polymorphic_override   , register_1arg_vec_polymorphic_override@@ -42,9 +48,11 @@  import           Control.Monad (when) import           Control.Monad.IO.Class (liftIO)-import           Control.Lens import qualified Data.List as List+import qualified Data.Maybe as Maybe import qualified Data.Text as Text+import           Lens.Micro ((^.), to)+import           Lens.Micro.Mtl (use) import           Numeric (readDec) import qualified System.Info as Info @@ -55,7 +63,6 @@ import           Lang.Crucible.Backend import           Lang.Crucible.CFG.Common (GlobalVar) import           Lang.Crucible.Simulator.ExecutionTree (FnState(UseOverride))-import           Lang.Crucible.Panic (panic) import           Lang.Crucible.Simulator.OverrideSim import           Lang.Crucible.Utils.MonadVerbosity (getLogFunction) import           Lang.Crucible.Simulator.RegMap@@ -68,10 +75,9 @@ import           Lang.Crucible.LLVM.Functions (registerFunPtr, bindLLVMFunc) import           Lang.Crucible.LLVM.MemModel import           Lang.Crucible.LLVM.MemModel.CallStack (CallStack)-import qualified Lang.Crucible.LLVM.Intrinsics.Cast as Cast+import qualified Lang.Crucible.LLVM.Intrinsics.Declare as Decl import qualified Lang.Crucible.LLVM.Intrinsics.Match as Match import           Lang.Crucible.LLVM.Translation.Monad-import           Lang.Crucible.LLVM.Translation.Types  -- | This type represents an implementation of an LLVM intrinsic function in -- Crucible.@@ -81,10 +87,8 @@ -- LLVM memory model, such as Macaw. data LLVMOverride p sym ext 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 ::+  { llvmOvDecl :: Decl.Declare args ret+  , llvmOvDefn ::       IsSymInterface sym =>       GlobalVar Mem ->       Ctx.Assignment (RegEntry sym) args ->@@ -94,9 +98,28 @@     -- (@OverrideSim@).   } +llvmOvSymbol :: LLVMOverride p sym ext args ret -> L.Symbol+llvmOvSymbol = Decl.decName . llvmOvDecl++llvmOvName :: LLVMOverride p sym ext args ret -> FunctionName+llvmOvName ov =+  let L.Symbol nm = llvmOvSymbol ov in+  functionNameFromText (Text.pack nm)++llvmOvArgs :: LLVMOverride p sym ext args ret -> CtxRepr args+llvmOvArgs = Decl.decArgs . llvmOvDecl++llvmOvRet :: LLVMOverride p sym ext args ret -> TypeRepr ret+llvmOvRet = Decl.decRet . llvmOvDecl+ data SomeLLVMOverride p sym ext =   forall args ret. SomeLLVMOverride (LLVMOverride p sym ext args ret) +-- | Map 'llvmOverride_decl' inside a 'SomeLLVMOverride'.+someLlvmOverrideDeclare :: SomeLLVMOverride p sym ext -> Decl.SomeDeclare+someLlvmOverrideDeclare (SomeLLVMOverride ov) =+  Decl.SomeDeclare (llvmOvDecl ov)+ -- | Convenient LLVM representation of the @size_t@ type. llvmSizeT :: HasPtrWidth wptr => L.Type llvmSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth@@ -110,7 +133,7 @@ newtype MakeOverride p sym ext arch =   MakeOverride     { runMakeOverride ::-        L.Declare ->+        Decl.SomeDeclare ->         -- Decoded version of the name in the declaration         Maybe ABI.DecodedName ->         LLVMContext arch ->@@ -138,39 +161,23 @@ ------------------------------------------------------------------------ -- ** register_llvm_override --- | 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 ::++llvmOverrideToTypedOverride ::+  IsSymInterface sym =>   HasLLVMAnn sym =>-  FunctionName ->-  CtxRepr args ->-  TypeRepr ret ->-  CtxRepr args' ->-  TypeRepr ret' ->-  (forall rtp' l' a'. IsSymInterface sym =>-   Ctx.Assignment (RegEntry sym) args ->-   OverrideSim p sym ext rtp' l' a' (RegValue sym ret)) ->-  OverrideSim p sym ext rtp l a (Override p sym ext args' ret')-build_llvm_override fnm args ret args' ret' llvmOverride =-  ovrWithBackend $ \bak ->-  do fargs <--       case Cast.castLLVMArgs fnm bak args args' of-         Left err ->-           panic "Intrinsics.build_llvm_override"-             (Cast.printValCastError err ++-               [ "in function: " ++ Text.unpack (functionName fnm) ])-         Right f -> pure f-     fret <--       case Cast.castLLVMRet fnm bak ret ret' of-         Left err ->-           panic "Intrinsics.build_llvm_override"-             (Cast.printValCastError err ++-               [ "in function: " ++ Text.unpack (functionName fnm) ])-         Right f -> pure f-     return $ mkOverride' fnm ret' $-            do RegMap xs <- getOverrideArgs-               Cast.applyValCast fret =<< llvmOverride =<< Cast.applyArgCast fargs xs+  GlobalVar Mem ->+  LLVMOverride p sym ext args ret ->+  TypedOverride p sym ext args ret+llvmOverrideToTypedOverride mvar ov =+  TypedOverride+  { typedOverrideArgs = llvmOvArgs ov+  , typedOverrideRet = llvmOvRet ov+  , typedOverrideHandler =+      \args -> do+        let argEntries =+              Ctx.zipWith (\t (RV v) -> RegEntry t v) (llvmOvArgs ov) args+        llvmOvDefn ov mvar argEntries+  }  polymorphic1_llvm_override :: forall p sym ext arch wptr.   (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>@@ -207,13 +214,36 @@ polymorphic1_vec_llvm_override prefix fn =   OverrideTemplate (Match.PrefixMatch prefix) (register_1arg_vec_polymorphic_override prefix fn) +-- | Create an 'OverrideTemplate' for an intrinsic in the @llvm.{s,u}cmp.*@+-- family. These can be instantiated at multiple types, including:+--+-- * @i2 \@llvm.scmp.i2.i32(i32, i32)@++-- * @i8 \@llvm.scmp.i8.i8(i8, i8)@+--+-- * etc.+--+-- Note that the argument and result types are allowed to be different, so the+-- @fn@ argument is parameterized by two separate 'NatRepr's.+polymorphic_cmp_llvm_override :: forall p sym ext arch wptr.+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  String ->+  (forall argSz resSz.+    (1 <= argSz, 2 <= resSz) =>+    NatRepr argSz ->+    NatRepr resSz ->+    SomeLLVMOverride p sym ext) ->+  OverrideTemplate p sym ext arch+polymorphic_cmp_llvm_override prefix fn =+  OverrideTemplate (Match.PrefixMatch prefix) (register_cmp_polymorphic_override prefix fn)+ register_1arg_polymorphic_override :: forall p sym ext arch wptr.   (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>   String ->   (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym ext) ->   MakeOverride p sym ext arch register_1arg_polymorphic_override prefix overrideFn =-  MakeOverride $ \(L.Declare{ L.decName = L.Symbol nm }) _ _ ->+  MakeOverride $ \(Decl.SomeDeclare (Decl.Declare{ Decl.decName = L.Symbol nm })) _ _ ->     case List.stripPrefix prefix nm of       Just ('.':'i': (readDec -> (sz,[]):_))         | Some w <- mkNatRepr sz@@ -240,7 +270,7 @@     SomeLLVMOverride p sym ext) ->   MakeOverride p sym ext arch register_1arg_vec_polymorphic_override prefix overrideFn =-  MakeOverride $ \(L.Declare{ L.decName = L.Symbol nm }) _ _ ->+  MakeOverride $ \(Decl.SomeDeclare (Decl.Declare{ Decl.decName = L.Symbol nm })) _ _ ->     case List.stripPrefix prefix nm of       Just ('.':'v':suffix1)         | (vecSzStr, 'i':intSzStr) <- break (== 'i') suffix1@@ -252,14 +282,43 @@         -> Just (overrideFn vecSzRepr intSzRepr)       _ -> Nothing +-- | Register an override for an intrinsic in the @llvm.{s,u}cmp.*@ family.+-- (See the Haddocks for 'polymorphic_cmp_llvm_override' for details on what+-- this means.) This function is responsible for parsing the suffixes in the+-- intrinsic's name, which encodes the sizes of the argument and result types.+-- As some examples:+--+-- * @.i2.i32@ (argument size @32@, result size @2@)+--+-- * @.i8.i64@ (argument size @64@, result size @8@)+register_cmp_polymorphic_override :: forall p sym ext arch wptr.+  (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>+  String ->+  (forall argSz resSz.+    (1 <= argSz, 2 <= resSz) =>+    NatRepr argSz ->+    NatRepr resSz ->+    SomeLLVMOverride p sym ext) ->+  MakeOverride p sym ext arch+register_cmp_polymorphic_override prefix overrideFn =+  MakeOverride $ \(Decl.SomeDeclare (Decl.Declare{ Decl.decName = L.Symbol nm })) _ _ ->+    case List.stripPrefix prefix nm of+      Just ('.':'i': (readDec -> (resSz,rest):_))+        | '.':'i': (readDec -> (argSz,[]):_) <- rest+        , Some argW <- mkNatRepr argSz+        , Some resW <- mkNatRepr resSz+        , Just LeqProof <- testLeq (knownNat @1) argW+        , Just LeqProof <- testLeq (knownNat @2) resW+        -> Just (overrideFn argW resW)+      _ -> Nothing+ basic_llvm_override :: forall p args ret sym ext arch wptr.   (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) =>   LLVMOverride p sym ext args ret ->   OverrideTemplate p sym ext arch basic_llvm_override ovr = OverrideTemplate matcher regOvr   where-    ovrDecl = llvmOverride_declare ovr-    L.Symbol ovrNm = L.decName ovrDecl+    L.Symbol ovrNm = llvmOvSymbol ovr     isDarwin = Info.os == "darwin"      matcher :: Match.TemplateMatcher@@ -268,8 +327,8 @@      regOvr :: MakeOverride p sym ext arch     regOvr = do-      MakeOverride $ \requestedDecl _ _ -> do-        let L.Symbol requestedNm = L.decName requestedDecl+      MakeOverride $ \(Decl.SomeDeclare requestedDecl) _ _ -> do+        let L.Symbol requestedNm = Decl.decName requestedDecl         -- If we are on Darwin and the function name contains Darwin-specific         -- prefixes or suffixes, change the name of the override to the         -- name containing prefixes/suffixes. See Note [Darwin aliases] in@@ -277,8 +336,8 @@         -- do this.         let ovr' | isDarwin                  , ovrNm == Match.stripDarwinAliases requestedNm-                 = ovr { llvmOverride_declare =-                           ovrDecl { L.decName = L.Symbol requestedNm }}+                 = let decl = (llvmOvDecl ovr) { Decl.decName = L.Symbol requestedNm } in+                   ovr { llvmOvDecl = decl }                   | otherwise                  = ovr@@ -291,47 +350,53 @@ -- 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 -} ->+  Decl.Declare args' ret' {- ^ Requested declaration -} ->+  LLVMOverride p sym ext args ret ->   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?+isMatchingDeclaration requested provided =+  let args = Decl.decArgs requested in+  let ret = Decl.decRet requested in+  and+  [ Decl.decName requested == llvmOvSymbol provided+  , matchingArgList args (llvmOvArgs provided)+  , Maybe.isJust (testEquality ret (llvmOvRet provided))   ] - where- matchingArgList [] [] = True- matchingArgList [] _  = L.decVarArgs requested- matchingArgList _  [] = L.decVarArgs provided- matchingArgList (x:xs) (y:ys) = x `L.eqTypeModuloOpaquePtrs` y && matchingArgList xs ys+  where+  matchingArgList ::+    Ctx.Assignment TypeRepr ctx1 ->+    Ctx.Assignment TypeRepr ctx2 ->+    Bool+  -- Ignore varargs as long as the rest of the arguments match (VectorRepr+  -- AnyRepr is how Crucible-LLVM represents varargs).+  matchingArgList (rest Ctx.:> VectorRepr AnyRepr) ys = matchingArgList rest ys+  matchingArgList xs (rest Ctx.:> VectorRepr AnyRepr) = matchingArgList xs rest+  matchingArgList xs ys = Maybe.isJust (testEquality xs ys) -register_llvm_override :: forall p args ret sym ext arch wptr rtp l a.+register_llvm_override ::+  forall p args ret args' ret' sym ext arch wptr rtp l a.   (IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym) =>   LLVMOverride p sym ext args ret ->-  L.Declare ->+  Decl.Declare args' ret' ->   LLVMContext arch ->   OverrideSim p sym ext rtp l a () register_llvm_override llvmOverride requestedDecl llvmctx = do-  let decl = llvmOverride_declare llvmOverride-  if not (isMatchingDeclaration requestedDecl decl) then-    do when (L.decName requestedDecl == L.decName decl) $+  let ?lc = llvmctx^.llvmTypeCtx+  if not (isMatchingDeclaration requestedDecl llvmOverride) then+    do when (Decl.decName requestedDecl == llvmOvSymbol llvmOverride) $          do logFn <- getLogFunction             liftIO $ logFn 3 $ unlines               [ "Mismatched declaration signatures"               , " *** requested: " ++ show requestedDecl-              , " *** found: "     ++ show decl-              , ""+              , " *** found args: " ++ show (llvmOvArgs llvmOverride)+              , " *** found ret: " ++ show (llvmOvRet llvmOverride)               ]   else do_register_llvm_override llvmctx llvmOverride  -- | 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.+-- 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@@ -342,20 +407,17 @@   LLVMOverride p sym ext args ret ->   OverrideSim p sym ext rtp l a () do_register_llvm_override llvmctx llvmOverride = do-  let decl = llvmOverride_declare llvmOverride-  let (L.Symbol str_nm) = L.decName decl+  let nm@(L.Symbol str_nm) = llvmOvSymbol llvmOverride   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-           (\asgn -> llvmOverride_def llvmOverride mvar asgn)-    bindLLVMFunc mvar (L.decName decl) args ret (UseOverride o)+  let typedOv = llvmOverrideToTypedOverride mvar llvmOverride+  let o = runTypedOverride fnm typedOv+  let args = typedOverrideArgs typedOv+  let ret = typedOverrideRet typedOv+  bindLLVMFunc mvar nm args ret (UseOverride o)  -- | Create an allocation for an override and register it. --@@ -374,7 +436,7 @@   [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 symb@(L.Symbol nm) = llvmOvSymbol llvmOverride   let mvar = llvmMemVar llvmctx   mem <- readGlobal mvar   (_ptr, mem') <- liftIO (registerFunPtr bak mem nm symb aliases)
+ src/Lang/Crucible/LLVM/Intrinsics/Declare.hs view
@@ -0,0 +1,110 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Declare+-- Description      : Function declarations+-- Copyright        : (c) Galois, Inc 2026+-- License          : BSD3+-- Maintainer       : Langston Barrett <langston@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}++module Lang.Crucible.LLVM.Intrinsics.Declare+  ( Declare(..)+  , SomeDeclare(SomeDeclare)+  , fromHandle+  , fromSomeHandle+  , fromLLVM+  , fromLLVMWithWarnings+  ) where++import qualified Control.Monad.Fail as Fail+import           Control.Monad.IO.Class (liftIO)+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import           Data.Traversable (for)++import qualified Text.LLVM.AST as L++import qualified Data.Parameterized.Context as Ctx++import qualified What4.FunctionName as WFN++import qualified Lang.Crucible.FunctionHandle as CFH+import           Lang.Crucible.Simulator.OverrideSim (OverrideSim)+import qualified Lang.Crucible.Types as CT+import           Lang.Crucible.Utils.MonadVerbosity (getLogFunction)++import           Lang.Crucible.LLVM.MemModel.Pointer (HasPtrWidth)+import           Lang.Crucible.LLVM.Translation.Types (llvmDeclToFunHandleRepr')+import           Lang.Crucible.LLVM.TypeContext (TypeContext)++-- | The declaration of a function.+--+-- Used primarily for matching LLVM overrides to the declarations in LLVM+-- modules or S-expression programs.+data Declare args ret+  = Declare+    { decName :: L.Symbol+    , decArgs :: Ctx.Assignment CT.TypeRepr args+    , decRet :: CT.TypeRepr ret+    }+  deriving Show++data SomeDeclare = forall args ret. SomeDeclare (Declare args ret)++fromHandle :: CFH.FnHandle args ret -> Declare args ret+fromHandle hdl =+  Declare+  { decName = L.Symbol (Text.unpack (WFN.functionName (CFH.handleName hdl)))+  , decArgs = CFH.handleArgTypes hdl+  , decRet = CFH.handleReturnType hdl+  }++fromSomeHandle :: CFH.SomeHandle -> SomeDeclare+fromSomeHandle (CFH.SomeHandle hdl) = SomeDeclare (fromHandle hdl)++fromLLVM ::+  ( ?lc :: TypeContext+  , HasPtrWidth wptr+  , Fail.MonadFail m+  ) =>+  L.Declare ->+  m SomeDeclare+fromLLVM decl =+  llvmDeclToFunHandleRepr' decl $ \args ret ->+    pure $+      SomeDeclare $+        Declare+        { decName = L.decName decl+        , decArgs = args+        , decRet = ret+        }++-- | Internal, for 'Fail.MonadFail' instance+newtype EitherString a = EitherString (Either String a)+  deriving (Applicative, Functor, Monad)++instance Fail.MonadFail EitherString where+  fail = EitherString . Left++-- | Apply 'fromLLVM' in a loop, warning on failures+fromLLVMWithWarnings ::+  ( ?lc :: TypeContext+  , HasPtrWidth wptr+  ) =>+  [L.Declare] ->+  OverrideSim p sym ext rtp l a [SomeDeclare]+fromLLVMWithWarnings decls =+  fmap Maybe.catMaybes $+    for decls $ \decl -> do+      case fromLLVM decl of+        EitherString (Left err) -> do+          logFn <- getLogFunction+          let msg = unlines ["Unliftable LLVM declaration", show decl, show err]+          liftIO $ logFn 3 msg+          pure Nothing+        EitherString (Right d) ->+          pure (Just d)
src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs view
@@ -29,7 +29,6 @@ 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 ((.&.))@@ -134,7 +133,9 @@   , SomeLLVMOverride llvmPrefetchOverride_preLLVM10    , SomeLLVMOverride llvmStacksave+  , SomeLLVMOverride llvmStacksave_preLLVM18   , SomeLLVMOverride llvmStackrestore+  , SomeLLVMOverride llvmStackrestore_preLLVM18    , SomeLLVMOverride (llvmBSwapOverride (knownNat @2))  -- 16 = 2 * 8   , SomeLLVMOverride (llvmBSwapOverride (knownNat @4))  -- 32 = 4 * 8@@ -160,6 +161,22 @@   , SomeLLVMOverride llvmSinOverride_F64   , SomeLLVMOverride llvmCosOverride_F32   , SomeLLVMOverride llvmCosOverride_F64+  , SomeLLVMOverride llvmTanOverride_F32+  , SomeLLVMOverride llvmTanOverride_F64+  , SomeLLVMOverride llvmAsinOverride_F32+  , SomeLLVMOverride llvmAsinOverride_F64+  , SomeLLVMOverride llvmAcosOverride_F32+  , SomeLLVMOverride llvmAcosOverride_F64+  , SomeLLVMOverride llvmAtanOverride_F32+  , SomeLLVMOverride llvmAtanOverride_F64+  , SomeLLVMOverride llvmAtan2Override_F32+  , SomeLLVMOverride llvmAtan2Override_F64+  , SomeLLVMOverride llvmSinhOverride_F32+  , SomeLLVMOverride llvmSinhOverride_F64+  , SomeLLVMOverride llvmCoshOverride_F32+  , SomeLLVMOverride llvmCoshOverride_F64+  , SomeLLVMOverride llvmTanhOverride_F32+  , SomeLLVMOverride llvmTanhOverride_F64   , SomeLLVMOverride llvmPowOverride_F32   , SomeLLVMOverride llvmPowOverride_F64   , SomeLLVMOverride llvmExpOverride_F32@@ -307,8 +324,54 @@     , Poly1VecLLVMOverride $ \vecSz intSz ->         SomeLLVMOverride (llvmVectorReduceUmin vecSz intSz)     )++  , ("llvm.smax"+    , Poly1VecLLVMOverride $ \vecSz intSz ->+        SomeLLVMOverride (llvmSmaxVector vecSz intSz)+    )+  , ("llvm.smin"+    , Poly1VecLLVMOverride $ \vecSz intSz ->+        SomeLLVMOverride (llvmSminVector vecSz intSz)+    )+  , ("llvm.umax"+    , Poly1VecLLVMOverride $ \vecSz intSz ->+        SomeLLVMOverride (llvmUmaxVector vecSz intSz)+    )+  , ("llvm.umin"+    , Poly1VecLLVMOverride $ \vecSz intSz ->+        SomeLLVMOverride (llvmUminVector vecSz intSz)+    )   ] +-- | An LLVM override for the @llvm.{s,u}cmp.*@ family of intrinsics. These+-- overrides have a unique shape in that:+--+-- 1. Both their argument and result types are polymorphic integer types (which+--    are allowed to be different), and+--+-- 2. The result integer type must have a size of at least 2 bits.+newtype PolyCmpLLVMOverride p sym ext+  = PolyCmpLLVMOverride+      (forall argSz resSz+         . (1 <= argSz, 2 <= resSz)+        => NatRepr argSz+        -> NatRepr resSz+        -> SomeLLVMOverride p sym ext)++poly_cmp_llvm_overrides ::+  IsSymInterface sym =>+  [(String, PolyCmpLLVMOverride p sym ext)]+poly_cmp_llvm_overrides =+  [ ("llvm.scmp"+    , PolyCmpLLVMOverride $ \argSz resSz ->+        SomeLLVMOverride (llvmScmp argSz resSz)+    )+  , ("llvm.ucmp"+    , PolyCmpLLVMOverride $ \argSz resSz ->+        SomeLLVMOverride (llvmUcmp argSz resSz)+    )+  ]+ ------------------------------------------------------------------------ -- ** Declarations @@ -467,17 +530,47 @@     ovrWithBackend $ \bak ->       liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.ubsantrap() called" "") +-- | TODO(#130): This override ought to impose proof obligations related to+-- proper block scoping. llvmStacksave   :: (IsSymInterface sym, HasPtrWidth wptr)   => LLVMOverride p sym ext EmptyCtx (LLVMPointerType wptr) llvmStacksave =+  [llvmOvr| i8* @llvm.stacksave.p0() |]+  (\_memOps _args -> mkNull)++-- | TODO(#130): This override ought to impose proof obligations related to+-- proper block scoping.+--+-- See also 'llvmStacksave'. This version exists for compatibility with+-- pre-18 versions of LLVM, where @llvm.stacksave@ always assumed that the+-- returned pointer value resides in address space 0.+llvmStacksave_preLLVM18+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext EmptyCtx (LLVMPointerType wptr)+llvmStacksave_preLLVM18 =   [llvmOvr| i8* @llvm.stacksave() |]   (\_memOps _args -> mkNull) +-- | TODO(#130): This override ought to impose proof obligations related to+-- proper block scoping. llvmStackrestore   :: (IsSymInterface sym, HasPtrWidth wptr)   => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) UnitType llvmStackrestore =+  [llvmOvr| void @llvm.stackrestore.p0( i8* ) |]+  (\_memOps _args -> return ())++-- | TODO(#130): This override ought to impose proof obligations related to+-- proper block scoping.+--+-- See also 'llvmStackrestore'. This version exists for compatibility with+-- pre-18 versions of LLVM, where @llvm.stackrestore@ always assumed that the+-- pointer argument resides in address space 0.+llvmStackrestore_preLLVM18+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) UnitType+llvmStackrestore_preLLVM18 =   [llvmOvr| void @llvm.stackrestore( i8* ) |]   (\_memOps _args -> return ()) @@ -1159,6 +1252,150 @@   [llvmOvr| double @llvm.cos.f64( double ) |]   (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Cos) args) +llvmTanOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanOverride_F32 =+  [llvmOvr| float @llvm.tan.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Tan) args)++llvmTanOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanOverride_F64 =+  [llvmOvr| double @llvm.tan.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Tan) args)++llvmAsinOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAsinOverride_F32 =+  [llvmOvr| float @llvm.asin.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arcsin) args)++llvmAsinOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAsinOverride_F64 =+  [llvmOvr| double @llvm.asin.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arcsin) args)++llvmAcosOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAcosOverride_F32 =+  [llvmOvr| float @llvm.acos.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arccos) args)++llvmAcosOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAcosOverride_F64 =+  [llvmOvr| double @llvm.acos.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arccos) args)++llvmAtanOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtanOverride_F32 =+  [llvmOvr| float @llvm.atan.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arctan) args)++llvmAtanOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtanOverride_F64 =+  [llvmOvr| double @llvm.atan.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Arctan) args)++llvmSinhOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinhOverride_F32 =+  [llvmOvr| float @llvm.sinh.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Sinh) args)++llvmSinhOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinhOverride_F64 =+  [llvmOvr| double @llvm.sinh.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Sinh) args)++llvmCoshOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCoshOverride_F32 =+  [llvmOvr| float @llvm.cosh.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Cosh) args)++llvmCoshOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCoshOverride_F64 =+  [llvmOvr| double @llvm.cosh.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Cosh) args)++llvmTanhOverride_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanhOverride_F32 =+  [llvmOvr| float @llvm.tanh.f32( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Tanh) args)++llvmTanhOverride_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanhOverride_F64 =+  [llvmOvr| double @llvm.tanh.f64( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Tanh) args)++llvmAtan2Override_F32 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtan2Override_F32 =+  [llvmOvr| float @llvm.atan2.f32( float, float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 W4.Arctan2) args)++llvmAtan2Override_F64 ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtan2Override_F64 =+  [llvmOvr| double @llvm.atan2.f64( double, double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 W4.Arctan2) args)+ llvmPowOverride_F32 ::   IsSymInterface sym =>   LLVMOverride p sym ext@@ -1469,6 +1706,115 @@         (BVType intSz) llvmVectorReduceUmin = llvmVectorReduce "umin" callVectorReduceUmin +-- | Build an 'LLVMOverride' for a vector map intrinsic.+llvmVectorMap ::+  (1 <= intSz) =>+  -- | The name of the operation to map (@umin@, @smin@, etc.).+  String ->+  -- | The semantics of the override.+  (forall r args ret.+    IsSymInterface sym =>+    RegEntry sym (VectorType (BVType intSz)) ->+    RegEntry sym (VectorType (BVType intSz)) ->+    OverrideSim p sym ext r args ret (V.Vector (SymBV sym intSz))) ->+  -- | The size of the vector type.+  NatRepr vecSz ->+  -- | The size of the integer type.+  NatRepr intSz ->+  LLVMOverride p sym ext+    (EmptyCtx ::> VectorType (BVType intSz) ::> VectorType (BVType intSz))+    (VectorType (BVType intSz))+llvmVectorMap opName callMap vecSz intSz =+  let nm = L.Symbol ("llvm." ++ opName +++                     ".v" ++ show (natValue vecSz) +++                     "i" ++ show (natValue intSz)) in+    [llvmOvr| <#vecSz x #intSz> $nm( <#vecSz x #intSz>, <#vecSz x #intSz> ) |]+    (\_memOps args -> Ctx.uncurryAssignment callMap args)++llvmSmaxVector ::+  (1 <= intSz) =>+  NatRepr vecSz ->+  NatRepr intSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> VectorType (BVType intSz) ::> VectorType (BVType intSz))+     (VectorType (BVType intSz))+llvmSmaxVector = llvmVectorMap "smax" callVectorMapSmax++llvmSminVector ::+  (1 <= intSz) =>+  NatRepr vecSz ->+  NatRepr intSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> VectorType (BVType intSz) ::> VectorType (BVType intSz))+     (VectorType (BVType intSz))+llvmSminVector = llvmVectorMap "smin" callVectorMapSmin++llvmUmaxVector ::+  (1 <= intSz) =>+  NatRepr vecSz ->+  NatRepr intSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> VectorType (BVType intSz) ::> VectorType (BVType intSz))+     (VectorType (BVType intSz))+llvmUmaxVector = llvmVectorMap "umax" callVectorMapUmax++llvmUminVector ::+  (1 <= intSz) =>+  NatRepr vecSz ->+  NatRepr intSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> VectorType (BVType intSz) ::> VectorType (BVType intSz))+     (VectorType (BVType intSz))+llvmUminVector = llvmVectorMap "umin" callVectorMapUmin++-- | Build an 'LLVMOverride' for an @llvm.{s,u}cmp.*@ intrinsic.+llvmCmp ::+  forall argSz resSz p sym ext.+  (1 <= argSz, 2 <= resSz) =>+  -- | The name of the operation (@scmp@ or @ucmp@).+  String ->+  -- | The semantics of the override.+  (forall r args ret.+    IsSymInterface sym =>+    RegEntry sym (BVType argSz) ->+    RegEntry sym (BVType argSz) ->+    OverrideSim p sym ext r args ret (SymBV sym resSz)) ->+  -- | The size of the argument type.+  NatRepr argSz ->+  -- | The size of the result type.+  NatRepr resSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> BVType argSz ::> BVType argSz)+     (BVType resSz)+llvmCmp cmpOpName cmpOp argSz resSz+  | (LeqProof :: LeqProof 1 resSz) <-+      leqTrans (LeqProof @1 @2) (LeqProof @2 @resSz)+  = let nm = L.Symbol ("llvm." ++ cmpOpName +++                       ".i" ++ show (natValue resSz) +++                       ".i" ++ show (natValue argSz)) in+      [llvmOvr| #resSz $nm( #argSz, #argSz ) |]+      (\_memOps args -> Ctx.uncurryAssignment cmpOp args)++llvmScmp ::+  forall argSz resSz p sym ext.+  (1 <= argSz, 2 <= resSz) =>+  NatRepr argSz ->+  NatRepr resSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> BVType argSz ::> BVType argSz)+     (BVType resSz)+llvmScmp argSz resSz = llvmCmp "scmp" (callScmp resSz) argSz resSz++llvmUcmp ::+  forall argSz resSz p sym ext.+  (1 <= argSz, 2 <= resSz) =>+  NatRepr argSz ->+  NatRepr resSz ->+  LLVMOverride p sym ext+     (EmptyCtx ::> BVType argSz ::> BVType argSz)+     (BVType resSz)+llvmUcmp argSz resSz = llvmCmp "ucmp" (callUcmp resSz) argSz resSz+ ------------------------------------------------------------------------ -- ** Implementations @@ -1933,8 +2279,8 @@ callIsFpclass regOp@(regValue -> op) (regValue -> test) = do   sym <- getSymInterface   let w1 = knownNat @1-  bv1 <- liftIO $ bvZero sym w1-  bv0 <- liftIO $ bvOne sym w1+  bv1 <- liftIO $ bvOne sym w1+  bv0 <- liftIO $ bvZero sym w1    let negative bit = liftIO $ do         isNeg <- iFloatIsNeg @_ @fi sym op@@ -2140,3 +2486,95 @@   sym <- getSymInterface   umax <- liftIO $ maxUnsignedBV sym intSz   callVectorReduce (bvUmin sym) umax vec++-- | The semantics of an LLVM vector map intrinsic.+callVectorMap ::+  -- | The operation to apply when mapping (e.g., @umin@, @smin@, etc.)+  (RegValue sym tp -> RegValue sym tp -> IO (RegValue sym tp)) ->+  -- | The first vector to map over.+  RegEntry sym (VectorType tp) ->+  -- | The second vector to map over.+  RegEntry sym (VectorType tp) ->+  -- | The result of mapping over the vectors.+  OverrideSim p sym ext r args ret (V.Vector (RegValue sym tp))+callVectorMap mapOp (regValue -> vec1) (regValue -> vec2) =+  liftIO $ V.zipWithM mapOp vec1 vec2++callVectorMapSmax ::+  (IsSymInterface sym, 1 <= intSz) =>+  RegEntry sym (VectorType (BVType intSz)) ->+  RegEntry sym (VectorType (BVType intSz)) ->+  OverrideSim p sym ext r args ret (V.Vector (SymBV sym intSz))+callVectorMapSmax vec1 vec2 = do+  sym <- getSymInterface+  callVectorMap (bvSmax sym) vec1 vec2++callVectorMapSmin ::+  (IsSymInterface sym, 1 <= intSz) =>+  RegEntry sym (VectorType (BVType intSz)) ->+  RegEntry sym (VectorType (BVType intSz)) ->+  OverrideSim p sym ext r args ret (V.Vector (SymBV sym intSz))+callVectorMapSmin vec1 vec2 = do+  sym <- getSymInterface+  callVectorMap (bvSmin sym) vec1 vec2++callVectorMapUmax ::+  (IsSymInterface sym, 1 <= intSz) =>+  RegEntry sym (VectorType (BVType intSz)) ->+  RegEntry sym (VectorType (BVType intSz)) ->+  OverrideSim p sym ext r args ret (V.Vector (SymBV sym intSz))+callVectorMapUmax vec1 vec2 = do+  sym <- getSymInterface+  callVectorMap (bvUmax sym) vec1 vec2++callVectorMapUmin ::+  (IsSymInterface sym, 1 <= intSz) =>+  RegEntry sym (VectorType (BVType intSz)) ->+  RegEntry sym (VectorType (BVType intSz)) ->+  OverrideSim p sym ext r args ret (V.Vector (SymBV sym intSz))+callVectorMapUmin vec1 vec2 = do+  sym <- getSymInterface+  callVectorMap (bvUmin sym) vec1 vec2++-- | The semantics of an @llvm.{s,u}cmp.*@ intrinsic.+callCmp ::+  forall argSz resSz p sym ext r args ret.+  (IsSymInterface sym, 1 <= argSz, 2 <= resSz) =>+  -- | The semantics of a bitvector less-than operation (either signed or+  -- unsigned).+  (sym -> SymBV sym argSz -> SymBV sym argSz -> IO (Pred sym)) ->+  -- | The size of the result type.+  NatRepr resSz ->+  RegEntry sym (BVType argSz) ->+  RegEntry sym (BVType argSz) ->+  OverrideSim p sym ext r args ret (SymBV sym resSz)+callCmp bvLtOp resSz (regValue -> x) (regValue -> y)+  | (LeqProof :: LeqProof 1 resSz) <-+      leqTrans (LeqProof @1 @2) (LeqProof @2 @resSz)+  = do sym <- getSymInterface+       liftIO $+         do xLtY <- bvLtOp sym x y+            xEqY <- bvEq sym x y+            zero <- bvZero sym resSz+            one <- bvOne sym resSz+            negOne <- bvNeg sym one+            -- If x < y, return -1. If x == y, return 0. If x > y, return 1.+            bvIte sym xLtY negOne =<< bvIte sym xEqY zero one++callScmp ::+  forall argSz resSz p sym ext r args ret.+  (IsSymInterface sym, 1 <= argSz, 2 <= resSz) =>+  NatRepr resSz ->+  RegEntry sym (BVType argSz) ->+  RegEntry sym (BVType argSz) ->+  OverrideSim p sym ext r args ret (SymBV sym resSz)+callScmp = callCmp bvSlt++callUcmp ::+  forall argSz resSz p sym ext r args ret.+  (IsSymInterface sym, 1 <= argSz, 2 <= resSz) =>+  NatRepr resSz ->+  RegEntry sym (BVType argSz) ->+  RegEntry sym (BVType argSz) ->+  OverrideSim p sym ext r args ret (SymBV sym resSz)+callUcmp = callCmp bvUlt
src/Lang/Crucible/LLVM/Intrinsics/Libc.hs view
@@ -8,1841 +8,201 @@ ------------------------------------------------------------------------  {-# 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.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 qualified Lang.Crucible.LLVM.MemModel.Pointer as Ptr-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---- | All libc overrides.------ This list is useful to other Crucible frontends based on the LLVM memory--- model (e.g., Macaw).-libc_overrides ::-  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-  , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>-  [SomeLLVMOverride p sym ext]-libc_overrides =-  [ SomeLLVMOverride llvmAbortOverride-  , SomeLLVMOverride llvmAssertRtnOverride-  , SomeLLVMOverride llvmAssertFailOverride-  , SomeLLVMOverride llvmMemcpyOverride-  , SomeLLVMOverride llvmMemcpyChkOverride-  , SomeLLVMOverride llvmMemmoveOverride-  , SomeLLVMOverride llvmMemsetOverride-  , SomeLLVMOverride llvmMemsetChkOverride-  , SomeLLVMOverride llvmMallocOverride-  , SomeLLVMOverride llvmCallocOverride-  , SomeLLVMOverride llvmFreeOverride-  , SomeLLVMOverride llvmReallocOverride-  , SomeLLVMOverride llvmStrlenOverride-  , SomeLLVMOverride llvmPrintfOverride-  , SomeLLVMOverride llvmPrintfChkOverride-  , SomeLLVMOverride llvmPutsOverride-  , SomeLLVMOverride llvmPutCharOverride-  , SomeLLVMOverride llvmExitOverride-  , SomeLLVMOverride llvmGetenvOverride-  , SomeLLVMOverride llvmHtonlOverride-  , SomeLLVMOverride llvmHtonsOverride-  , SomeLLVMOverride llvmNtohlOverride-  , SomeLLVMOverride llvmNtohsOverride-  , SomeLLVMOverride llvmAbsOverride-  , SomeLLVMOverride llvmLAbsOverride_32-  , SomeLLVMOverride llvmLAbsOverride_64-  , SomeLLVMOverride llvmLLAbsOverride--  , SomeLLVMOverride llvmCeilOverride-  , SomeLLVMOverride llvmCeilfOverride-  , SomeLLVMOverride llvmFloorOverride-  , SomeLLVMOverride llvmFloorfOverride-  , SomeLLVMOverride llvmFmaOverride-  , SomeLLVMOverride llvmFmafOverride-  , SomeLLVMOverride llvmIsinfOverride-  , SomeLLVMOverride llvm__isinfOverride-  , SomeLLVMOverride llvm__isinffOverride-  , SomeLLVMOverride llvmIsnanOverride-  , SomeLLVMOverride llvm__isnanOverride-  , SomeLLVMOverride llvm__isnanfOverride-  , SomeLLVMOverride llvm__isnandOverride-  , SomeLLVMOverride llvmSqrtOverride-  , SomeLLVMOverride llvmSqrtfOverride-  , SomeLLVMOverride llvmSinOverride-  , SomeLLVMOverride llvmSinfOverride-  , SomeLLVMOverride llvmCosOverride-  , SomeLLVMOverride llvmCosfOverride-  , SomeLLVMOverride llvmTanOverride-  , SomeLLVMOverride llvmTanfOverride-  , SomeLLVMOverride llvmAsinOverride-  , SomeLLVMOverride llvmAsinfOverride-  , SomeLLVMOverride llvmAcosOverride-  , SomeLLVMOverride llvmAcosfOverride-  , SomeLLVMOverride llvmAtanOverride-  , SomeLLVMOverride llvmAtanfOverride-  , SomeLLVMOverride llvmSinhOverride-  , SomeLLVMOverride llvmSinhfOverride-  , SomeLLVMOverride llvmCoshOverride-  , SomeLLVMOverride llvmCoshfOverride-  , SomeLLVMOverride llvmTanhOverride-  , SomeLLVMOverride llvmTanhfOverride-  , SomeLLVMOverride llvmAsinhOverride-  , SomeLLVMOverride llvmAsinhfOverride-  , SomeLLVMOverride llvmAcoshOverride-  , SomeLLVMOverride llvmAcoshfOverride-  , SomeLLVMOverride llvmAtanhOverride-  , SomeLLVMOverride llvmAtanhfOverride-  , SomeLLVMOverride llvmHypotOverride-  , SomeLLVMOverride llvmHypotfOverride-  , SomeLLVMOverride llvmAtan2Override-  , SomeLLVMOverride llvmAtan2fOverride-  , SomeLLVMOverride llvmPowfOverride-  , SomeLLVMOverride llvmPowOverride-  , SomeLLVMOverride llvmExpOverride-  , SomeLLVMOverride llvmExpfOverride-  , SomeLLVMOverride llvmLogOverride-  , SomeLLVMOverride llvmLogfOverride-  , SomeLLVMOverride llvmExpm1Override-  , SomeLLVMOverride llvmExpm1fOverride-  , SomeLLVMOverride llvmLog1pOverride-  , SomeLLVMOverride llvmLog1pfOverride-  , SomeLLVMOverride llvmExp2Override-  , SomeLLVMOverride llvmExp2fOverride-  , SomeLLVMOverride llvmLog2Override-  , SomeLLVMOverride llvmLog2fOverride-  , SomeLLVMOverride llvmExp10Override-  , SomeLLVMOverride llvmExp10fOverride-  , SomeLLVMOverride llvm__exp10Override-  , SomeLLVMOverride llvm__exp10fOverride-  , SomeLLVMOverride llvmLog10Override-  , SomeLLVMOverride llvmLog10fOverride--  , SomeLLVMOverride cxa_atexitOverride-  , SomeLLVMOverride posixMemalignOverride-  ]----------------------------------------------------------------------------- ** Declarations---llvmMemcpyOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-           (EmptyCtx ::> LLVMPointerType wptr-                     ::> LLVMPointerType wptr-                     ::> BVType wptr)-           (LLVMPointerType wptr)-llvmMemcpyOverride =-  [llvmOvr| i8* @memcpy( i8*, i8*, size_t ) |]-  (\memOps args ->-       do sym <- getSymInterface-          volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat-          Ctx.uncurryAssignment (callMemcpy memOps)-                                (args :> volatile)-          return $ regValue $ args^._1 -- return first argument-    )---llvmMemcpyChkOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr-                   ::> LLVMPointerType wptr-                   ::> BVType wptr-                   ::> BVType wptr)-         (LLVMPointerType wptr)-llvmMemcpyChkOverride =-  [llvmOvr| i8* @__memcpy_chk ( i8*, i8*, size_t, size_t ) |]-  (\memOps args ->-      do let args' = Empty :> (args^._1) :> (args^._2) :> (args^._3)-         sym <- getSymInterface-         volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat-         Ctx.uncurryAssignment (callMemcpy memOps)-                               (args' :> volatile)-         return $ regValue $ args^._1 -- return first argument-    )--llvmMemmoveOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> (LLVMPointerType wptr)-                   ::> (LLVMPointerType wptr)-                   ::> BVType wptr)-         (LLVMPointerType wptr)-llvmMemmoveOverride =-  [llvmOvr| i8* @memmove( i8*, i8*, size_t ) |]-  (\memOps args ->-      do sym <- getSymInterface-         volatile <- liftIO (RegEntry knownRepr <$> bvZero sym knownNat)-         Ctx.uncurryAssignment (callMemmove memOps)-                               (args :> volatile)-         return $ regValue $ args^._1 -- return first argument-    )--llvmMemsetOverride :: forall p sym ext wptr.-     (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr-                   ::> BVType 32-                   ::> BVType wptr)-         (LLVMPointerType wptr)-llvmMemsetOverride =-  [llvmOvr| i8* @memset( i8*, i32, size_t ) |]-  (\memOps args ->-      do sym <- getSymInterface-         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 <$> bvZero sym knownNat)-         callMemset memOps dest val len volatile-         return (regValue dest)-    )--llvmMemsetChkOverride-  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr-                 ::> BVType 32-                 ::> BVType wptr-                 ::> BVType wptr)-         (LLVMPointerType wptr)-llvmMemsetChkOverride =-  [llvmOvr| i8* @__memset_chk( i8*, i32, size_t, size_t ) |]-  (\memOps args ->-      do sym <- getSymInterface-         let dest = args^._1-         val <- liftIO-              (RegEntry knownRepr <$> bvTrunc sym knownNat (regValue (args^._2)))-         let len = args^._3-         volatile <- liftIO-            (RegEntry knownRepr <$> bvZero sym knownNat)-         callMemset memOps dest val len volatile-         return (regValue dest)-    )----------------------------------------------------------------------------- *** Allocation--llvmCallocOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?lc :: TypeContext, ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> BVType wptr ::> BVType wptr)-         (LLVMPointerType wptr)-llvmCallocOverride =-  let alignment = maxAlignment (llvmDataLayout ?lc) in-  [llvmOvr| i8* @calloc( size_t, size_t ) |]-  (\memOps args -> Ctx.uncurryAssignment (callCalloc memOps alignment) args)---llvmReallocOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?lc :: TypeContext, ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr)-         (LLVMPointerType wptr)-llvmReallocOverride =-  let alignment = maxAlignment (llvmDataLayout ?lc) in-  [llvmOvr| i8* @realloc( i8*, size_t ) |]-  (\memOps args -> Ctx.uncurryAssignment (callRealloc memOps alignment) args)--llvmMallocOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?lc :: TypeContext, ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> BVType wptr)-         (LLVMPointerType wptr)-llvmMallocOverride =-  let alignment = maxAlignment (llvmDataLayout ?lc) in-  [llvmOvr| i8* @malloc( size_t ) |]-  (\memOps args -> Ctx.uncurryAssignment (callMalloc memOps alignment) args)--posixMemalignOverride ::-  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-  , ?lc :: TypeContext, ?memOpts :: MemOptions ) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> LLVMPointerType wptr-                ::> BVType wptr-                ::> BVType wptr)-      (BVType 32)-posixMemalignOverride =-  [llvmOvr| i32 @posix_memalign( i8**, size_t, size_t ) |]-  (\memOps args -> Ctx.uncurryAssignment (callPosixMemalign memOps) args)---llvmFreeOverride-  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr)-         UnitType-llvmFreeOverride =-  [llvmOvr| void @free( i8* ) |]-  (\memOps args -> Ctx.uncurryAssignment (callFree memOps) args)----------------------------------------------------------------------------- *** Strings and I/O--llvmPrintfOverride-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> LLVMPointerType wptr-                   ::> VectorType AnyType)-         (BVType 32)-llvmPrintfOverride =-  [llvmOvr| i32 @printf( i8*, ... ) |]-  (\memOps args -> Ctx.uncurryAssignment (callPrintf memOps) args)--llvmPrintfChkOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> BVType 32-                   ::> LLVMPointerType wptr-                   ::> VectorType AnyType)-         (BVType 32)-llvmPrintfChkOverride =-  [llvmOvr| i32 @__printf_chk( i32, i8*, ... ) |]-  (\memOps args -> Ctx.uncurryAssignment (\_flg -> callPrintf memOps) args)---llvmPutCharOverride-  :: (IsSymInterface sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext (EmptyCtx ::> BVType 32) (BVType 32)-llvmPutCharOverride =-  [llvmOvr| i32 @putchar( i32 ) |]-  (\memOps args -> Ctx.uncurryAssignment (callPutChar memOps) args)---llvmPutsOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType 32)-llvmPutsOverride =-  [llvmOvr| i32 @puts( i8* ) |]-  (\memOps args -> Ctx.uncurryAssignment (callPuts memOps) args)--llvmStrlenOverride-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType wptr)-llvmStrlenOverride =-  [llvmOvr| size_t @strlen( i8* ) |]-  (\memOps args -> Ctx.uncurryAssignment (callStrlen memOps) args)----------------------------------------------------------------------------- ** Implementations----------------------------------------------------------------------------- *** Allocation--callRealloc-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> Alignment-  -> RegEntry sym (LLVMPointerType wptr)-  -> RegEntry sym (BVType wptr)-  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))-callRealloc mvar alignment (regValue -> ptr) (regValue -> sz) =-  ovrWithBackend $ \bak -> 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-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?lc :: TypeContext, ?memOpts :: MemOptions )-  => 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 mvar (regValue -> outPtr) (regValue -> align) (regValue -> sz) =-  ovrWithBackend $ \bak ->-    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 <- bvZero sym knownNat-                  return (z, mem'')--callMalloc-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> Alignment-  -> RegEntry sym (BVType wptr)-  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))-callMalloc mvar alignment (regValue -> sz) =-  ovrWithBackend $ \bak ->-    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-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> Alignment-  -> RegEntry sym (BVType wptr)-  -> RegEntry sym (BVType wptr)-  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))-callCalloc mvar alignment-           (regValue -> sz)-           (regValue -> num) =-  ovrWithBackend $ \bak ->-    modifyGlobal mvar $ \mem -> liftIO $-      doCalloc bak mem sz num alignment--callFree-  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)-  => GlobalVar Mem-  -> RegEntry sym (LLVMPointerType wptr)-  -> OverrideSim p sym ext r args ret ()-callFree mvar-           (regValue -> ptr) =-  ovrWithBackend $ \bak ->-    modifyGlobal mvar $ \mem -> liftIO $-      do mem' <- doFree bak mem ptr-         return ((), mem')----------------------------------------------------------------------------- *** Memory manipulation--callMemcpy-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => 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 mvar-           (regValue -> dest)-           (regValue -> src)-           (RegEntry (BVRepr w) len)-           _volatile =-  ovrWithBackend $ \bak ->-    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-  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr-     , ?memOpts :: MemOptions )-  => 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 mvar-           (regValue -> dest)-           (regValue -> src)-           (RegEntry (BVRepr w) len)-           _volatile =-  -- FIXME? add assertions about alignment-  ovrWithBackend $ \bak ->-    modifyGlobal mvar $ \mem -> liftIO $-      do mem' <- doMemcpy bak w mem False dest src len-         return ((), mem')--callMemset-  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)-  => 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 mvar-           (regValue -> dest)-           (regValue -> val)-           (RegEntry (BVRepr w) len)-           _volatile =-  ovrWithBackend $ \bak ->-    modifyGlobal mvar $ \mem -> liftIO $-      do mem' <- doMemset bak w mem dest val len-         return ((), mem')----------------------------------------------------------------------------- *** Strings and I/O--callPutChar-  :: IsSymInterface sym-  => GlobalVar Mem-  -> RegEntry sym (BVType 32)-  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))-callPutChar _mvar- (regValue -> ch) = do-    h <- printHandle <$> getContext-    let chval = maybe '?' (toEnum . fromInteger) (BV.asUnsigned <$> asBV ch)-    liftIO $ hPutChar h chval-    return ch--callPuts-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> RegEntry sym (LLVMPointerType wptr)-  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))-callPuts mvar-  (regValue -> strPtr) =-    ovrWithBackend $ \bak -> 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-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> RegEntry sym (LLVMPointerType wptr)-  -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr))-callStrlen mvar (regValue -> strPtr) =-  ovrWithBackend $ \bak -> do-    mem <- readGlobal mvar-    liftIO $ strLen bak mem strPtr--callAssert-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> 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 mvar (Empty :> _pfn :> _pfile :> _pline :> ptxt ) =-  ovrWithBackend $ \bak -> 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-      = abnormalExitBehavior ?intrinsicsOpts `elem` [AlwaysFail, OnlyAssertFail]--callExit :: ( IsSymInterface sym-            , ?intrinsicsOpts :: IntrinsicsOptions )-         => RegEntry sym (BVType 32)-         -> OverrideSim p sym ext r args ret (RegValue sym UnitType)-callExit ec =-  ovrWithBackend $ \bak -> liftIO $ do-    let sym = backendGetSym bak-    when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $-      do cond <- bvEq sym (regValue ec) =<< bvZero sym 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-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?memOpts :: MemOptions )-  => GlobalVar Mem-  -> RegEntry sym (LLVMPointerType wptr)-  -> RegEntry sym (VectorType AnyType)-  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))-callPrintf mvar-  (regValue -> strPtr)-  (regValue -> valist) =-    ovrWithBackend $ \bak -> 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) p@(LLVMPointer _blk bv)) ->-         do isBv <- liftIO (Ptr.ptrIsBv sym p)-            liftIO $ assert bak isBv $-              AssertFailureSimError-               "Passed a pointer to printf where a bitvector was expected"-               ""-            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 ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmCeilOverride =-  [llvmOvr| double @ceil( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment callCeil args)--llvmCeilfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmCeilfOverride =-  [llvmOvr| float @ceilf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment callCeil args)---llvmFloorOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmFloorOverride =-  [llvmOvr| double @floor( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment callFloor args)--llvmFloorfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmFloorfOverride =-  [llvmOvr| float @floorf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment callFloor args)--llvmFmafOverride ::-     forall sym p ext-   . IsSymInterface sym-  => LLVMOverride p sym ext-        (EmptyCtx ::> FloatType SingleFloat-                  ::> FloatType SingleFloat-                  ::> FloatType SingleFloat)-        (FloatType SingleFloat)-llvmFmafOverride =-  [llvmOvr| float @fmaf( float, float, float ) |]-  (\_memOps args -> Ctx.uncurryAssignment callFMA args)--llvmFmaOverride ::-     forall sym p ext-   . IsSymInterface sym-  => LLVMOverride p sym ext-        (EmptyCtx ::> FloatType DoubleFloat-                  ::> FloatType DoubleFloat-                  ::> FloatType DoubleFloat)-        (FloatType DoubleFloat)-llvmFmaOverride =-  [llvmOvr| double @fma( double, double, double ) |]-  (\_memOps args -> Ctx.uncurryAssignment callFMA 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 ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (BVType 32)-llvmIsinfOverride =-  [llvmOvr| i32 @isinf( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (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 ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (BVType 32)-llvm__isinfOverride =-  [llvmOvr| i32 @__isinf( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args)--llvm__isinffOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (BVType 32)-llvm__isinffOverride =-  [llvmOvr| i32 @__isinff( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args)--llvmIsnanOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (BVType 32)-llvmIsnanOverride =-  [llvmOvr| i32 @isnan( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (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 ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (BVType 32)-llvm__isnanOverride =-  [llvmOvr| i32 @__isnan( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)--llvm__isnanfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (BVType 32)-llvm__isnanfOverride =-  [llvmOvr| i32 @__isnanf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)---- macOS compiles isnan() to __isnand() when the argument is a double.-llvm__isnandOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (BVType 32)-llvm__isnandOverride =-  [llvmOvr| i32 @__isnand( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)--llvmSqrtOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmSqrtOverride =-  [llvmOvr| double @sqrt( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment callSqrt args)--llvmSqrtfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmSqrtfOverride =-  [llvmOvr| float @sqrtf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment callSqrt args)--callSpecialFunction1 ::-  forall fi p sym ext r args ret.-  (IsSymInterface sym, KnownRepr FloatInfoRepr fi) =>-  W4.SpecialFunction (EmptyCtx ::> W4.R) ->-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))-callSpecialFunction1 fn (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ iFloatSpecialFunction1 sym (knownRepr :: FloatInfoRepr fi) fn x--callSpecialFunction2 ::-  forall fi p sym ext r args ret.-  (IsSymInterface sym, KnownRepr FloatInfoRepr fi) =>-  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 fn (regValue -> x) (regValue -> y) = do-  sym <- getSymInterface-  liftIO $ iFloatSpecialFunction2 sym (knownRepr :: FloatInfoRepr fi) fn x y--callCeil ::-  forall fi p sym ext r args ret.-  IsSymInterface sym =>-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))-callCeil (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ iFloatRound @_ @fi sym RTP x--callFloor ::-  forall fi p sym ext r args ret.-  IsSymInterface sym =>-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))-callFloor (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ iFloatRound @_ @fi sym RTN x---- | An implementation of @libc@'s @fma@ function.-callFMA ::-     forall fi p sym ext r args ret-   . IsSymInterface sym-  => RegEntry sym (FloatType fi)-  -> RegEntry sym (FloatType fi)-  -> RegEntry sym (FloatType fi)-  -> OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))-callFMA (regValue -> x) (regValue -> y) (regValue -> z) = do-  sym <- getSymInterface-  liftIO $ iFloatFMA @_ @fi sym 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 ext r args ret.-  (IsSymInterface sym, 1 <= w) =>-  NatRepr w ->-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType w))-callIsinf w (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ do-    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-    bv1 <- bvOne sym w-    bvNeg1 <- bvNeg sym bv1-    bv0 <- bvZero sym w-    res0 <- bvIte sym isInfP bv1 bv0-    bvIte sym isInfN bvNeg1 res0--callIsnan ::-  forall fi w p sym ext r args ret.-  (IsSymInterface sym, 1 <= w) =>-  NatRepr w ->-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType w))-callIsnan w (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ do-    isnan  <- iFloatIsNaN @_ @fi sym x-    bv1 <- bvOne sym w-    bv0 <- bvZero sym 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 bv1 bv0--callSqrt ::-  forall fi p sym ext r args ret.-  IsSymInterface sym =>-  RegEntry sym (FloatType fi) ->-  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))-callSqrt (regValue -> x) = do-  sym <- getSymInterface-  liftIO $ iFloatSqrt @_ @fi sym defaultRM x----------------------------------------------------------------------------- **** Circular trigonometry functions---- sin(f)--llvmSinOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmSinOverride =-  [llvmOvr| double @sin( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args)--llvmSinfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmSinfOverride =-  [llvmOvr| float @sinf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args)---- cos(f)--llvmCosOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmCosOverride =-  [llvmOvr| double @cos( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args)--llvmCosfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmCosfOverride =-  [llvmOvr| float @cosf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args)---- tan(f)--llvmTanOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmTanOverride =-  [llvmOvr| double @tan( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args)--llvmTanfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmTanfOverride =-  [llvmOvr| float @tanf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args)---- asin(f)--llvmAsinOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAsinOverride =-  [llvmOvr| double @asin( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args)--llvmAsinfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAsinfOverride =-  [llvmOvr| float @asinf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args)---- acos(f)--llvmAcosOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAcosOverride =-  [llvmOvr| double @acos( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args)--llvmAcosfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAcosfOverride =-  [llvmOvr| float @acosf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args)---- atan(f)--llvmAtanOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAtanOverride =-  [llvmOvr| double @atan( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args)--llvmAtanfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAtanfOverride =-  [llvmOvr| float @atanf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args)----------------------------------------------------------------------------- **** Hyperbolic trigonometry functions---- sinh(f)--llvmSinhOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmSinhOverride =-  [llvmOvr| double @sinh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args)--llvmSinhfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmSinhfOverride =-  [llvmOvr| float @sinhf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args)---- cosh(f)--llvmCoshOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmCoshOverride =-  [llvmOvr| double @cosh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args)--llvmCoshfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmCoshfOverride =-  [llvmOvr| float @coshf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args)---- tanh(f)--llvmTanhOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmTanhOverride =-  [llvmOvr| double @tanh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args)--llvmTanhfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmTanhfOverride =-  [llvmOvr| float @tanhf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args)---- asinh(f)--llvmAsinhOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAsinhOverride =-  [llvmOvr| double @asinh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args)--llvmAsinhfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAsinhfOverride =-  [llvmOvr| float @asinhf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args)---- acosh(f)--llvmAcoshOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAcoshOverride =-  [llvmOvr| double @acosh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args)--llvmAcoshfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAcoshfOverride =-  [llvmOvr| float @acoshf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args)---- atanh(f)--llvmAtanhOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAtanhOverride =-  [llvmOvr| double @atanh( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args)--llvmAtanhfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAtanhfOverride =-  [llvmOvr| float @atanhf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args)----------------------------------------------------------------------------- **** Rectangular to polar coordinate conversion---- hypot(f)--llvmHypotOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmHypotOverride =-  [llvmOvr| double @hypot( double, double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args)--llvmHypotfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmHypotfOverride =-  [llvmOvr| float @hypotf( float, float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args)---- atan2(f)--llvmAtan2Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmAtan2Override =-  [llvmOvr| double @atan2( double, double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args)--llvmAtan2fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmAtan2fOverride =-  [llvmOvr| float @atan2f( float, float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args)----------------------------------------------------------------------------- **** Exponential and logarithm functions---- pow(f)--llvmPowfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmPowfOverride =-  [llvmOvr| float @powf( float, float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args)--llvmPowOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmPowOverride =-  [llvmOvr| double @pow( double, double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args)---- exp(f)--llvmExpOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmExpOverride =-  [llvmOvr| double @exp( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args)--llvmExpfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmExpfOverride =-  [llvmOvr| float @expf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args)---- log(f)--llvmLogOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmLogOverride =-  [llvmOvr| double @log( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args)--llvmLogfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmLogfOverride =-  [llvmOvr| float @logf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args)---- expm1(f)--llvmExpm1Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmExpm1Override =-  [llvmOvr| double @expm1( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args)--llvmExpm1fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmExpm1fOverride =-  [llvmOvr| float @expm1f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args)---- log1p(f)--llvmLog1pOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmLog1pOverride =-  [llvmOvr| double @log1p( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args)--llvmLog1pfOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmLog1pfOverride =-  [llvmOvr| float @log1pf( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args)----------------------------------------------------------------------------- **** Base 2 exponential and logarithm---- exp2(f)--llvmExp2Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmExp2Override =-  [llvmOvr| double @exp2( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args)--llvmExp2fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmExp2fOverride =-  [llvmOvr| float @exp2f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args)---- log2(f)--llvmLog2Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmLog2Override =-  [llvmOvr| double @log2( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args)--llvmLog2fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmLog2fOverride =-  [llvmOvr| float @log2f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args)----------------------------------------------------------------------------- **** Base 10 exponential and logarithm---- exp10(f)--llvmExp10Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmExp10Override =-  [llvmOvr| double @exp10( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)--llvmExp10fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmExp10fOverride =-  [llvmOvr| float @exp10f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)---- macOS uses __exp10(f) instead of exp10(f).--llvm__exp10Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvm__exp10Override =-  [llvmOvr| double @__exp10( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)--llvm__exp10fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvm__exp10fOverride =-  [llvmOvr| float @__exp10f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)---- log10(f)--llvmLog10Override ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType DoubleFloat)-     (FloatType DoubleFloat)-llvmLog10Override =-  [llvmOvr| double @log10( double ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args)--llvmLog10fOverride ::-  IsSymInterface sym =>-  LLVMOverride p sym ext-     (EmptyCtx ::> FloatType SingleFloat)-     (FloatType SingleFloat)-llvmLog10fOverride =-  [llvmOvr| float @log10f( float ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args)----------------------------------------------------------------------------- *** Other---- from OSX libc-llvmAssertRtnOverride-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-        (EmptyCtx ::> LLVMPointerType wptr-                  ::> LLVMPointerType wptr-                  ::> BVType 32-                  ::> LLVMPointerType wptr)-        UnitType-llvmAssertRtnOverride =-  [llvmOvr| void @__assert_rtn( i8*, i8*, i32, i8* ) |]-  callAssert---- From glibc-llvmAssertFailOverride-  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym-     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )-  => LLVMOverride p sym ext-        (EmptyCtx ::> LLVMPointerType wptr-                  ::> LLVMPointerType wptr-                  ::> BVType 32-                  ::> LLVMPointerType wptr)-        UnitType-llvmAssertFailOverride =-  [llvmOvr| void @__assert_fail( i8*, i8*, i32, i8* ) |]-  callAssert---llvmAbortOverride-  :: ( IsSymInterface sym-     , ?intrinsicsOpts :: IntrinsicsOptions )-  => LLVMOverride p sym ext EmptyCtx UnitType-llvmAbortOverride =-  [llvmOvr| void @abort() |]-  (\_ _args ->-     ovrWithBackend $ \bak -> 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 ext-   . ( IsSymInterface sym-     , ?intrinsicsOpts :: IntrinsicsOptions )-  => LLVMOverride p sym ext-         (EmptyCtx ::> BVType 32)-         UnitType-llvmExitOverride =-  [llvmOvr| void @exit( i32 ) |]-  (\_ args -> Ctx.uncurryAssignment callExit args)--llvmGetenvOverride-  :: (IsSymInterface sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext-        (EmptyCtx ::> LLVMPointerType wptr)-        (LLVMPointerType wptr)-llvmGetenvOverride =-  [llvmOvr| i8* @getenv( i8* ) |]-  (\_ _args -> do-    sym <- getSymInterface-    liftIO $ mkNullPointer sym PtrWidth)--llvmHtonlOverride ::-  (IsSymInterface sym, ?lc :: TypeContext) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 32)-      (BVType 32)-llvmHtonlOverride =-  [llvmOvr| i32 @htonl( i32 ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args)--llvmHtonsOverride ::-  (IsSymInterface sym, ?lc :: TypeContext) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 16)-      (BVType 16)-llvmHtonsOverride =-  [llvmOvr| i16 @htons( i16 ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args)--llvmNtohlOverride ::-  (IsSymInterface sym, ?lc :: TypeContext) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 32)-      (BVType 32)-llvmNtohlOverride =-  [llvmOvr| i32 @ntohl( i32 ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args)--llvmNtohsOverride ::-  (IsSymInterface sym, ?lc :: TypeContext) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 16)-      (BVType 16)-llvmNtohsOverride =-  [llvmOvr| i16 @ntohs( i16 ) |]-  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args)--llvmAbsOverride ::-  (IsSymInterface sym, HasLLVMAnn sym) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 32)-      (BVType 32)-llvmAbsOverride =-  [llvmOvr| i32 @abs( i32 ) |]-  (\mvar args ->-     do callStack <- callStackFromMemVar' mvar-        Ctx.uncurryAssignment (callLibcAbs 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 ext-      (EmptyCtx ::> BVType 32)-      (BVType 32)-llvmLAbsOverride_32 =-  [llvmOvr| i32 @labs( i32 ) |]-  (\mvar args ->-     do callStack <- callStackFromMemVar' mvar-        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @32)) args)--llvmLAbsOverride_64 ::-  (IsSymInterface sym, HasLLVMAnn sym) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 64)-      (BVType 64)-llvmLAbsOverride_64 =-  [llvmOvr| i64 @labs( i64 ) |]-  (\mvar args ->-     do callStack <- callStackFromMemVar' mvar-        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args)--llvmLLAbsOverride ::-  (IsSymInterface sym, HasLLVMAnn sym) =>-  LLVMOverride p sym ext-      (EmptyCtx ::> BVType 64)-      (BVType 64)-llvmLLAbsOverride =-  [llvmOvr| i64 @llabs( i64 ) |]-  (\mvar args ->-     do callStack <- callStackFromMemVar' mvar-        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args)--callBSwap ::-  (1 <= width, IsSymInterface sym) =>-  NatRepr width ->-  RegEntry sym (BVType (width * 8)) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))-callBSwap widthRepr (regValue -> vec) = do-  sym <- getSymInterface-  liftIO $ bvSwap sym 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 ext r args ret.-  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>-  CallStack ->-  CheckAbsIntMin ->-  NatRepr w ->-  RegEntry sym (BVType w) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType w))-callAbs callStack checkIntMin widthRepr (regValue -> src) = do-  sym <- getSymInterface-  ovrWithBackend $ \bak -> liftIO $ do-    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, IsSymInterface sym, HasLLVMAnn sym) =>-  CallStack ->-  NatRepr w ->-  RegEntry sym (BVType w) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType w))-callLibcAbs callStack = callAbs callStack LibcAbsIntMinUB--callLLVMAbs ::-  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>-  CallStack ->-  NatRepr w ->-  RegEntry sym (BVType w) ->-  RegEntry sym (BVType 1) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType w))-callLLVMAbs 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 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, IsSymInterface sym, ?lc :: TypeContext) =>-  NatRepr width ->-  RegEntry sym (BVType (width * 8)) ->-  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))-callBSwapIfLittleEndian widthRepr vec =-  case (llvmDataLayout ?lc)^.intLayout of-    BigEndian    -> pure (regValue vec)-    LittleEndian -> callBSwap widthRepr vec--------------------------------------------------------------------------------- atexit stuff--cxa_atexitOverride-  :: (IsSymInterface sym, HasPtrWidth wptr)-  => LLVMOverride p sym ext-        (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> LLVMPointerType wptr)-        (BVType 32)-cxa_atexitOverride =-  [llvmOvr| i32 @__cxa_atexit( void (i8*)*, i8*, i8* ) |]-  (\_ _args -> do-    sym <- getSymInterface-    liftIO $ bvZero sym 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+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc+  ( module Lang.Crucible.LLVM.Intrinsics.Libc+  , module Lang.Crucible.LLVM.Intrinsics.Libc.Math+  , module Lang.Crucible.LLVM.Intrinsics.Libc.Stdio+  , module Lang.Crucible.LLVM.Intrinsics.Libc.Stdlib+  , module Lang.Crucible.LLVM.Intrinsics.Libc.String+  ) where++import qualified Codec.Binary.UTF8.Generic as UTF8+import           Control.Monad (when)+import           Control.Monad.IO.Class (liftIO)+import           Lens.Micro ((^.))++import           Data.Parameterized.Context ( pattern (:>), pattern Empty )+import qualified Data.Parameterized.Context as Ctx++import           What4.Interface++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemModel.Strings as CStr+import           Lang.Crucible.LLVM.QQ( llvmOvr )+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.LLVM.Intrinsics.Common+import           Lang.Crucible.LLVM.Intrinsics.Libc.Math+import           Lang.Crucible.LLVM.Intrinsics.Libc.Stdio+import           Lang.Crucible.LLVM.Intrinsics.Libc.Stdlib+import           Lang.Crucible.LLVM.Intrinsics.Libc.String+import           Lang.Crucible.LLVM.Intrinsics.Options++-- | All libc overrides.+--+-- This list is useful to other Crucible frontends based on the LLVM memory+-- model (e.g., Macaw).+libc_overrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  [SomeLLVMOverride p sym ext]+libc_overrides =+  [ SomeLLVMOverride llvmAssertRtnOverride+  , SomeLLVMOverride llvmAssertFailOverride+  , SomeLLVMOverride llvmHtonlOverride+  , SomeLLVMOverride llvmHtonsOverride+  , SomeLLVMOverride llvmNtohlOverride+  , SomeLLVMOverride llvmNtohsOverride+  ]+  ++ mathOverrides+  ++ stdioOverrides+  ++ stdlibOverrides+  ++ stringOverrides++------------------------------------------------------------------------+-- ** Implementations++callAssert+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> 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 mvar (Empty :> _pfn :> _pfile :> _pline :> ptxt ) =+  ovrWithBackend $ \bak -> do+    let sym = backendGetSym bak+    when failUponExit $+      do mem <- readGlobal mvar+         txt <- liftIO $ CStr.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+      = abnormalExitBehavior ?intrinsicsOpts `elem` [AlwaysFail, OnlyAssertFail]+++------------------------------------------------------------------------+-- *** Other++-- from OSX libc+llvmAssertRtnOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+        (EmptyCtx ::> LLVMPointerType wptr+                  ::> LLVMPointerType wptr+                  ::> BVType 32+                  ::> LLVMPointerType wptr)+        UnitType+llvmAssertRtnOverride =+  [llvmOvr| void @__assert_rtn( i8*, i8*, i32, i8* ) |]+  callAssert++-- From glibc+llvmAssertFailOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+        (EmptyCtx ::> LLVMPointerType wptr+                  ::> LLVMPointerType wptr+                  ::> BVType 32+                  ::> LLVMPointerType wptr)+        UnitType+llvmAssertFailOverride =+  [llvmOvr| void @__assert_fail( i8*, i8*, i32, i8* ) |]+  callAssert++++llvmHtonlOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmHtonlOverride =+  [llvmOvr| i32 @htonl( i32 ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args)++llvmHtonsOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 16)+      (BVType 16)+llvmHtonsOverride =+  [llvmOvr| i16 @htons( i16 ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args)++llvmNtohlOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmNtohlOverride =+  [llvmOvr| i32 @ntohl( i32 ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args)++llvmNtohsOverride ::+  (IsSymInterface sym, ?lc :: TypeContext) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 16)+      (BVType 16)+llvmNtohsOverride =+  [llvmOvr| i16 @ntohs( i16 ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args)+++callBSwap ::+  (1 <= width, IsSymInterface sym) =>+  NatRepr width ->+  RegEntry sym (BVType (width * 8)) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))+callBSwap widthRepr (regValue -> vec) = do+  sym <- getSymInterface+  liftIO $ bvSwap sym widthRepr vec+++-- | 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, IsSymInterface sym, ?lc :: TypeContext) =>+  NatRepr width ->+  RegEntry sym (BVType (width * 8)) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8)))+callBSwapIfLittleEndian widthRepr vec =+  case (llvmDataLayout ?lc)^.intLayout of+    BigEndian    -> pure (regValue vec)+    LittleEndian -> callBSwap widthRepr vec+++----------------------------------------------------------------------------+
+ src/Lang/Crucible/LLVM/Intrinsics/Libc/Math.hs view
@@ -0,0 +1,961 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libc.Math+-- Description      : Override definitions for C @math.h@ functions+-- Copyright        : (c) Galois, Inc 2026+-- License          : BSD3+-- Maintainer       : Galois, Inc. <crux@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc.Math+  ( -- * @math.h@ overrides+    mathOverrides+    -- * Override declarations+  , llvmCeilOverride+  , llvmCeilfOverride+  , llvmFloorOverride+  , llvmFloorfOverride+  , llvmFmaOverride+  , llvmFmafOverride+  , llvmIsinfOverride+  , llvm__isinfOverride+  , llvm__isinffOverride+  , llvmIsnanOverride+  , llvm__isnanOverride+  , llvm__isnanfOverride+  , llvm__isnandOverride+  , llvmSqrtOverride+  , llvmSqrtfOverride+  , llvmSinOverride+  , llvmSinfOverride+  , llvmCosOverride+  , llvmCosfOverride+  , llvmTanOverride+  , llvmTanfOverride+  , llvmAsinOverride+  , llvmAsinfOverride+  , llvmAcosOverride+  , llvmAcosfOverride+  , llvmAtanOverride+  , llvmAtanfOverride+  , llvmSinhOverride+  , llvmSinhfOverride+  , llvmCoshOverride+  , llvmCoshfOverride+  , llvmTanhOverride+  , llvmTanhfOverride+  , llvmAsinhOverride+  , llvmAsinhfOverride+  , llvmAcoshOverride+  , llvmAcoshfOverride+  , llvmAtanhOverride+  , llvmAtanhfOverride+  , llvmHypotOverride+  , llvmHypotfOverride+  , llvmAtan2Override+  , llvmAtan2fOverride+  , llvmPowfOverride+  , llvmPowOverride+  , llvmExpOverride+  , llvmExpfOverride+  , llvmLogOverride+  , llvmLogfOverride+  , llvmExpm1Override+  , llvmExpm1fOverride+  , llvmLog1pOverride+  , llvmLog1pfOverride+  , llvmExp2Override+  , llvmExp2fOverride+  , llvmLog2Override+  , llvmLog2fOverride+  , llvmExp10Override+  , llvmExp10fOverride+  , llvm__exp10Override+  , llvm__exp10fOverride+  , llvmLog10Override+  , llvmLog10fOverride+    -- * Implementation functions+  , callCeil+  , callFloor+  , callFMA+  , callIsinf+  , callIsnan+  , callSqrt+  , callSpecialFunction1+  , callSpecialFunction2+  , defaultRM+  ) where++import           Control.Monad.IO.Class (liftIO)++import qualified Data.Parameterized.Context as Ctx++import           What4.Interface+import qualified What4.SpecialFunctions as W4++import           Lang.Crucible.Backend+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap++import           Lang.Crucible.LLVM.QQ( llvmOvr )++import           Lang.Crucible.LLVM.Intrinsics.Common++-- | All @math.h@ overrides+mathOverrides ::+  IsSymInterface sym =>+  [SomeLLVMOverride p sym ext]+mathOverrides =+  [ SomeLLVMOverride llvmCeilOverride+  , SomeLLVMOverride llvmCeilfOverride+  , SomeLLVMOverride llvmFloorOverride+  , SomeLLVMOverride llvmFloorfOverride+  , SomeLLVMOverride llvmFmaOverride+  , SomeLLVMOverride llvmFmafOverride+  , SomeLLVMOverride llvmIsinfOverride+  , SomeLLVMOverride llvm__isinfOverride+  , SomeLLVMOverride llvm__isinffOverride+  , SomeLLVMOverride llvmIsnanOverride+  , SomeLLVMOverride llvm__isnanOverride+  , SomeLLVMOverride llvm__isnanfOverride+  , SomeLLVMOverride llvm__isnandOverride+  , SomeLLVMOverride llvmSqrtOverride+  , SomeLLVMOverride llvmSqrtfOverride+  , SomeLLVMOverride llvmSinOverride+  , SomeLLVMOverride llvmSinfOverride+  , SomeLLVMOverride llvmCosOverride+  , SomeLLVMOverride llvmCosfOverride+  , SomeLLVMOverride llvmTanOverride+  , SomeLLVMOverride llvmTanfOverride+  , SomeLLVMOverride llvmAsinOverride+  , SomeLLVMOverride llvmAsinfOverride+  , SomeLLVMOverride llvmAcosOverride+  , SomeLLVMOverride llvmAcosfOverride+  , SomeLLVMOverride llvmAtanOverride+  , SomeLLVMOverride llvmAtanfOverride+  , SomeLLVMOverride llvmSinhOverride+  , SomeLLVMOverride llvmSinhfOverride+  , SomeLLVMOverride llvmCoshOverride+  , SomeLLVMOverride llvmCoshfOverride+  , SomeLLVMOverride llvmTanhOverride+  , SomeLLVMOverride llvmTanhfOverride+  , SomeLLVMOverride llvmAsinhOverride+  , SomeLLVMOverride llvmAsinhfOverride+  , SomeLLVMOverride llvmAcoshOverride+  , SomeLLVMOverride llvmAcoshfOverride+  , SomeLLVMOverride llvmAtanhOverride+  , SomeLLVMOverride llvmAtanhfOverride+  , SomeLLVMOverride llvmHypotOverride+  , SomeLLVMOverride llvmHypotfOverride+  , SomeLLVMOverride llvmAtan2Override+  , SomeLLVMOverride llvmAtan2fOverride+  , SomeLLVMOverride llvmPowfOverride+  , SomeLLVMOverride llvmPowOverride+  , SomeLLVMOverride llvmExpOverride+  , SomeLLVMOverride llvmExpfOverride+  , SomeLLVMOverride llvmLogOverride+  , SomeLLVMOverride llvmLogfOverride+  , SomeLLVMOverride llvmExpm1Override+  , SomeLLVMOverride llvmExpm1fOverride+  , SomeLLVMOverride llvmLog1pOverride+  , SomeLLVMOverride llvmLog1pfOverride+  , SomeLLVMOverride llvmExp2Override+  , SomeLLVMOverride llvmExp2fOverride+  , SomeLLVMOverride llvmLog2Override+  , SomeLLVMOverride llvmLog2fOverride+  , SomeLLVMOverride llvmExp10Override+  , SomeLLVMOverride llvmExp10fOverride+  , SomeLLVMOverride llvm__exp10Override+  , SomeLLVMOverride llvm__exp10fOverride+  , SomeLLVMOverride llvmLog10Override+  , SomeLLVMOverride llvmLog10fOverride+  ]++------------------------------------------------------------------------+-- ** Declarations++llvmCeilOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCeilOverride =+  [llvmOvr| double @ceil( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment callCeil args)++llvmCeilfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCeilfOverride =+  [llvmOvr| float @ceilf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment callCeil args)+++llvmFloorOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmFloorOverride =+  [llvmOvr| double @floor( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment callFloor args)++llvmFloorfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmFloorfOverride =+  [llvmOvr| float @floorf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment callFloor args)++llvmFmafOverride ::+     forall sym p ext+   . IsSymInterface sym+  => LLVMOverride p sym ext+        (EmptyCtx ::> FloatType SingleFloat+                  ::> FloatType SingleFloat+                  ::> FloatType SingleFloat)+        (FloatType SingleFloat)+llvmFmafOverride =+  [llvmOvr| float @fmaf( float, float, float ) |]+  (\_memOps args -> Ctx.uncurryAssignment callFMA args)++llvmFmaOverride ::+     forall sym p ext+   . IsSymInterface sym+  => LLVMOverride p sym ext+        (EmptyCtx ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat+                  ::> FloatType DoubleFloat)+        (FloatType DoubleFloat)+llvmFmaOverride =+  [llvmOvr| double @fma( double, double, double ) |]+  (\_memOps args -> Ctx.uncurryAssignment callFMA 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 ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvmIsinfOverride =+  [llvmOvr| i32 @isinf( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (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 ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvm__isinfOverride =+  [llvmOvr| i32 @__isinf( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args)++llvm__isinffOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (BVType 32)+llvm__isinffOverride =+  [llvmOvr| i32 @__isinff( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args)++llvmIsnanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvmIsnanOverride =+  [llvmOvr| i32 @isnan( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (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 ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvm__isnanOverride =+  [llvmOvr| i32 @__isnan( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)++llvm__isnanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (BVType 32)+llvm__isnanfOverride =+  [llvmOvr| i32 @__isnanf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)++-- macOS compiles isnan() to __isnand() when the argument is a double.+llvm__isnandOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (BVType 32)+llvm__isnandOverride =+  [llvmOvr| i32 @__isnand( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args)++llvmSqrtOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSqrtOverride =+  [llvmOvr| double @sqrt( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment callSqrt args)++llvmSqrtfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSqrtfOverride =+  [llvmOvr| float @sqrtf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment callSqrt args)++------------------------------------------------------------------------+-- **** Circular trigonometry functions++-- sin(f)++llvmSinOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinOverride =+  [llvmOvr| double @sin( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args)++llvmSinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinfOverride =+  [llvmOvr| float @sinf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args)++-- cos(f)++llvmCosOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCosOverride =+  [llvmOvr| double @cos( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args)++llvmCosfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCosfOverride =+  [llvmOvr| float @cosf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args)++-- tan(f)++llvmTanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanOverride =+  [llvmOvr| double @tan( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args)++llvmTanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanfOverride =+  [llvmOvr| float @tanf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args)++-- asin(f)++llvmAsinOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAsinOverride =+  [llvmOvr| double @asin( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args)++llvmAsinfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAsinfOverride =+  [llvmOvr| float @asinf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args)++-- acos(f)++llvmAcosOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAcosOverride =+  [llvmOvr| double @acos( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args)++llvmAcosfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAcosfOverride =+  [llvmOvr| float @acosf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args)++-- atan(f)++llvmAtanOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtanOverride =+  [llvmOvr| double @atan( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args)++llvmAtanfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtanfOverride =+  [llvmOvr| float @atanf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args)++------------------------------------------------------------------------+-- **** Hyperbolic trigonometry functions++-- sinh(f)++llvmSinhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmSinhOverride =+  [llvmOvr| double @sinh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args)++llvmSinhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmSinhfOverride =+  [llvmOvr| float @sinhf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args)++-- cosh(f)++llvmCoshOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmCoshOverride =+  [llvmOvr| double @cosh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args)++llvmCoshfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmCoshfOverride =+  [llvmOvr| float @coshf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args)++-- tanh(f)++llvmTanhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmTanhOverride =+  [llvmOvr| double @tanh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args)++llvmTanhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmTanhfOverride =+  [llvmOvr| float @tanhf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args)++-- asinh(f)++llvmAsinhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAsinhOverride =+  [llvmOvr| double @asinh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args)++llvmAsinhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAsinhfOverride =+  [llvmOvr| float @asinhf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args)++-- acosh(f)++llvmAcoshOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAcoshOverride =+  [llvmOvr| double @acosh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args)++llvmAcoshfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAcoshfOverride =+  [llvmOvr| float @acoshf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args)++-- atanh(f)++llvmAtanhOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtanhOverride =+  [llvmOvr| double @atanh( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args)++llvmAtanhfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtanhfOverride =+  [llvmOvr| float @atanhf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args)++------------------------------------------------------------------------+-- **** Rectangular to polar coordinate conversion++-- hypot(f)++llvmHypotOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmHypotOverride =+  [llvmOvr| double @hypot( double, double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args)++llvmHypotfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmHypotfOverride =+  [llvmOvr| float @hypotf( float, float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args)++-- atan2(f)++llvmAtan2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmAtan2Override =+  [llvmOvr| double @atan2( double, double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args)++llvmAtan2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmAtan2fOverride =+  [llvmOvr| float @atan2f( float, float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args)++------------------------------------------------------------------------+-- **** Exponential and logarithm functions++-- pow(f)++llvmPowfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmPowfOverride =+  [llvmOvr| float @powf( float, float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args)++llvmPowOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmPowOverride =+  [llvmOvr| double @pow( double, double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args)++-- exp(f)++llvmExpOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExpOverride =+  [llvmOvr| double @exp( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args)++llvmExpfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExpfOverride =+  [llvmOvr| float @expf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args)++-- log(f)++llvmLogOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLogOverride =+  [llvmOvr| double @log( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args)++llvmLogfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLogfOverride =+  [llvmOvr| float @logf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args)++-- expm1(f)++llvmExpm1Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExpm1Override =+  [llvmOvr| double @expm1( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args)++llvmExpm1fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExpm1fOverride =+  [llvmOvr| float @expm1f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args)++-- log1p(f)++llvmLog1pOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog1pOverride =+  [llvmOvr| double @log1p( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args)++llvmLog1pfOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog1pfOverride =+  [llvmOvr| float @log1pf( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args)++------------------------------------------------------------------------+-- **** Base 2 exponential and logarithm++-- exp2(f)++llvmExp2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExp2Override =+  [llvmOvr| double @exp2( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args)++llvmExp2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExp2fOverride =+  [llvmOvr| float @exp2f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args)++-- log2(f)++llvmLog2Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog2Override =+  [llvmOvr| double @log2( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args)++llvmLog2fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog2fOverride =+  [llvmOvr| float @log2f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args)++------------------------------------------------------------------------+-- **** Base 10 exponential and logarithm++-- exp10(f)++llvmExp10Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmExp10Override =+  [llvmOvr| double @exp10( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)++llvmExp10fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmExp10fOverride =+  [llvmOvr| float @exp10f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)++-- macOS uses __exp10(f) instead of exp10(f).++llvm__exp10Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvm__exp10Override =+  [llvmOvr| double @__exp10( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)++llvm__exp10fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvm__exp10fOverride =+  [llvmOvr| float @__exp10f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args)++-- log10(f)++llvmLog10Override ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType DoubleFloat)+     (FloatType DoubleFloat)+llvmLog10Override =+  [llvmOvr| double @log10( double ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args)++llvmLog10fOverride ::+  IsSymInterface sym =>+  LLVMOverride p sym ext+     (EmptyCtx ::> FloatType SingleFloat)+     (FloatType SingleFloat)+llvmLog10fOverride =+  [llvmOvr| float @log10f( float ) |]+  (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args)++------------------------------------------------------------------------+-- ** Implementations++callSpecialFunction1 ::+  forall fi p sym ext r args ret.+  (IsSymInterface sym, KnownRepr FloatInfoRepr fi) =>+  W4.SpecialFunction (EmptyCtx ::> W4.R) ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callSpecialFunction1 fn (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ iFloatSpecialFunction1 sym (knownRepr :: FloatInfoRepr fi) fn x++callSpecialFunction2 ::+  forall fi p sym ext r args ret.+  (IsSymInterface sym, KnownRepr FloatInfoRepr fi) =>+  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 fn (regValue -> x) (regValue -> y) = do+  sym <- getSymInterface+  liftIO $ iFloatSpecialFunction2 sym (knownRepr :: FloatInfoRepr fi) fn x y++callCeil ::+  forall fi p sym ext r args ret.+  IsSymInterface sym =>+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callCeil (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ iFloatRound @_ @fi sym RTP x++callFloor ::+  forall fi p sym ext r args ret.+  IsSymInterface sym =>+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callFloor (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ iFloatRound @_ @fi sym RTN x++-- | An implementation of @libc@'s @fma@ function.+callFMA ::+     forall fi p sym ext r args ret+   . IsSymInterface sym+  => RegEntry sym (FloatType fi)+  -> RegEntry sym (FloatType fi)+  -> RegEntry sym (FloatType fi)+  -> OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callFMA (regValue -> x) (regValue -> y) (regValue -> z) = do+  sym <- getSymInterface+  liftIO $ iFloatFMA @_ @fi sym 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 ext r args ret.+  (IsSymInterface sym, 1 <= w) =>+  NatRepr w ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callIsinf w (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ do+    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+    bv1 <- bvOne sym w+    bvNeg1 <- bvNeg sym bv1+    bv0 <- bvZero sym w+    res0 <- bvIte sym isInfP bv1 bv0+    bvIte sym isInfN bvNeg1 res0++callIsnan ::+  forall fi w p sym ext r args ret.+  (IsSymInterface sym, 1 <= w) =>+  NatRepr w ->+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callIsnan w (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ do+    isnan  <- iFloatIsNaN @_ @fi sym x+    bv1 <- bvOne sym w+    bv0 <- bvZero sym 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 bv1 bv0++callSqrt ::+  forall fi p sym ext r args ret.+  IsSymInterface sym =>+  RegEntry sym (FloatType fi) ->+  OverrideSim p sym ext r args ret (RegValue sym (FloatType fi))+callSqrt (regValue -> x) = do+  sym <- getSymInterface+  liftIO $ iFloatSqrt @_ @fi sym defaultRM x++-- | 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/Libc/Stdio.hs view
@@ -0,0 +1,306 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libc.Stdio+-- Description      : Override definitions for C @stdio.h@ functions+-- Copyright        : (c) Galois, Inc 2026+-- License          : BSD3+-- Maintainer       : Galois, Inc. <crux@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc.Stdio+  ( -- * @stdio.h@ overrides+    stdioOverrides+    -- * Override declarations+  , llvmPrintfOverride+  , llvmPrintfChkOverride+  , llvmPutsOverride+  , llvmPutCharOverride+    -- * Implementation functions+  , callPrintf+  , callPutChar+  , callPuts+  , printfOps+  ) where++import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State (StateT(..), get, put)+import           Control.Monad.Trans.Class (MonadTrans(..))+import qualified Codec.Binary.UTF8.Generic as UTF8+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 Empty)+import qualified Data.Parameterized.Context as Ctx++import           What4.Interface++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Simulator (printHandle)+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.MemModel+import qualified Lang.Crucible.LLVM.MemModel.Generic as G+import qualified Lang.Crucible.LLVM.MemModel.Pointer as Ptr+import           Lang.Crucible.LLVM.MemModel.Strings as CStr+import qualified Lang.Crucible.LLVM.MemModel.Type as G+import           Lang.Crucible.LLVM.Printf+import           Lang.Crucible.LLVM.QQ( llvmOvr )++import           Lang.Crucible.LLVM.Intrinsics.Common++-- | All @stdio.h@ overrides+stdioOverrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?memOpts :: MemOptions ) =>+  [SomeLLVMOverride p sym ext]+stdioOverrides =+  [ SomeLLVMOverride llvmPrintfOverride+  , SomeLLVMOverride llvmPrintfChkOverride+  , SomeLLVMOverride llvmPutsOverride+  , SomeLLVMOverride llvmPutCharOverride+  ]++------------------------------------------------------------------------+-- ** Declarations++llvmPrintfOverride+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> VectorType AnyType)+         (BVType 32)+llvmPrintfOverride =+  [llvmOvr| i32 @printf( i8*, ... ) |]+  (\memOps args -> Ctx.uncurryAssignment (callPrintf memOps) args)++llvmPrintfChkOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> BVType 32+                   ::> LLVMPointerType wptr+                   ::> VectorType AnyType)+         (BVType 32)+llvmPrintfChkOverride =+  [llvmOvr| i32 @__printf_chk( i32, i8*, ... ) |]+  (\memOps args -> Ctx.uncurryAssignment (\_flg -> callPrintf memOps) args)+++llvmPutCharOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext (EmptyCtx ::> BVType 32) (BVType 32)+llvmPutCharOverride =+  [llvmOvr| i32 @putchar( i32 ) |]+  (\memOps args -> Ctx.uncurryAssignment (callPutChar memOps) args)+++llvmPutsOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType 32)+llvmPutsOverride =+  [llvmOvr| i32 @puts( i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callPuts memOps) args)++------------------------------------------------------------------------+-- ** Implementations++callPutChar+  :: IsSymInterface sym+  => GlobalVar Mem+  -> RegEntry sym (BVType 32)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPutChar _mvar+ (regValue -> ch) = do+    h <- printHandle <$> getContext+    let chval = maybe '?' (toEnum . fromInteger) (BV.asUnsigned <$> asBV ch)+    liftIO $ hPutChar h chval+    return ch++callPuts+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPuts mvar+  (regValue -> strPtr) =+    ovrWithBackend $ \bak -> do+      mem <- readGlobal mvar+      str <- liftIO $ CStr.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)++callPrintf+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (VectorType AnyType)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callPrintf mvar+  (regValue -> strPtr)+  (regValue -> valist) =+    ovrWithBackend $ \bak -> do+      mem <- readGlobal mvar+      formatStr <- liftIO $ CStr.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) p@(LLVMPointer _blk bv)) ->+         do isBv <- liftIO (Ptr.ptrIsBv sym p)+            liftIO $ assert bak isBv $+              AssertFailureSimError+               "Passed a pointer to printf where a bitvector was expected"+               ""+            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 $ CStr.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])+  }
+ src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdlib.hs view
@@ -0,0 +1,487 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libc.Stdlib+-- Description      : Override definitions for C @stdlib.h@ functions+-- Copyright        : (c) Galois, Inc 2026+-- License          : BSD3+-- Maintainer       : Galois, Inc. <crux@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc.Stdlib+  ( -- * @stdlib.h@ overrides+    stdlibOverrides+    -- * Override declarations+  , llvmMallocOverride+  , llvmCallocOverride+  , llvmFreeOverride+  , llvmReallocOverride+  , posixMemalignOverride+  , llvmAbortOverride+  , llvmExitOverride+  , llvmGetenvOverride+  , llvmAbsOverride+  , llvmLAbsOverride_32+  , llvmLAbsOverride_64+  , llvmLLAbsOverride+  , cxa_atexitOverride+    -- * Implementation functions+  , callMalloc+  , callCalloc+  , callFree+  , callRealloc+  , callPosixMemalign+  , callExit+  , callLibcAbs+  , callLLVMAbs+  , callAbs+  , CheckAbsIntMin(..)+  ) where++import           Control.Monad (when)+import           Control.Monad.IO.Class (liftIO)+import           Lens.Micro ((^.))++import qualified Data.BitVector.Sized as BV+import qualified Data.Parameterized.Context as Ctx++import           What4.Interface+import           What4.ProgramLoc (plSourceLoc)++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.Bytes (toBytes)+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.Generic as G+import           Lang.Crucible.LLVM.MemModel.Partial (annotateUB)+import           Lang.Crucible.LLVM.QQ( llvmOvr )+import           Lang.Crucible.LLVM.TypeContext++import           Lang.Crucible.LLVM.Intrinsics.Common+import           Lang.Crucible.LLVM.Intrinsics.Options++-- | All @stdlib.h@ overrides+stdlibOverrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) =>+  [SomeLLVMOverride p sym ext]+stdlibOverrides =+  [ SomeLLVMOverride llvmMallocOverride+  , SomeLLVMOverride llvmCallocOverride+  , SomeLLVMOverride llvmFreeOverride+  , SomeLLVMOverride llvmReallocOverride+  , SomeLLVMOverride posixMemalignOverride+  , SomeLLVMOverride llvmAbortOverride+  , SomeLLVMOverride llvmExitOverride+  , SomeLLVMOverride llvmGetenvOverride+  , SomeLLVMOverride llvmAbsOverride+  , SomeLLVMOverride llvmLAbsOverride_32+  , SomeLLVMOverride llvmLAbsOverride_64+  , SomeLLVMOverride llvmLLAbsOverride+  , SomeLLVMOverride cxa_atexitOverride+  ]++------------------------------------------------------------------------+-- ** Declarations++------------------------------------------------------------------------+-- *** Allocation++llvmCallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> BVType wptr ::> BVType wptr)+         (LLVMPointerType wptr)+llvmCallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @calloc( size_t, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callCalloc memOps alignment) args)+++llvmReallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr)+         (LLVMPointerType wptr)+llvmReallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @realloc( i8*, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callRealloc memOps alignment) args)++llvmMallocOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMallocOverride =+  let alignment = maxAlignment (llvmDataLayout ?lc) in+  [llvmOvr| i8* @malloc( size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callMalloc memOps alignment) args)++posixMemalignOverride ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?lc :: TypeContext, ?memOpts :: MemOptions ) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> LLVMPointerType wptr+                ::> BVType wptr+                ::> BVType wptr)+      (BVType 32)+posixMemalignOverride =+  [llvmOvr| i32 @posix_memalign( i8**, size_t, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callPosixMemalign memOps) args)+++llvmFreeOverride+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr)+         UnitType+llvmFreeOverride =+  [llvmOvr| void @free( i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callFree memOps) args)++------------------------------------------------------------------------+-- *** Process control++llvmAbortOverride+  :: ( IsSymInterface sym+     , ?intrinsicsOpts :: IntrinsicsOptions )+  => LLVMOverride p sym ext EmptyCtx UnitType+llvmAbortOverride =+  [llvmOvr| void @abort() |]+  (\_ _args ->+     ovrWithBackend $ \bak -> 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 ext+   . ( IsSymInterface sym+     , ?intrinsicsOpts :: IntrinsicsOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> BVType 32)+         UnitType+llvmExitOverride =+  [llvmOvr| void @exit( i32 ) |]+  (\_ args -> Ctx.uncurryAssignment callExit args)++llvmGetenvOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext+        (EmptyCtx ::> LLVMPointerType wptr)+        (LLVMPointerType wptr)+llvmGetenvOverride =+  [llvmOvr| i8* @getenv( i8* ) |]+  (\_ _args -> do+    sym <- getSymInterface+    liftIO $ mkNullPointer sym PtrWidth)++------------------------------------------------------------------------+-- *** Integer functions++llvmAbsOverride ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmAbsOverride =+  [llvmOvr| i32 @abs( i32 ) |]+  (\mvar args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs 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 ext+      (EmptyCtx ::> BVType 32)+      (BVType 32)+llvmLAbsOverride_32 =+  [llvmOvr| i32 @labs( i32 ) |]+  (\mvar args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @32)) args)++llvmLAbsOverride_64 ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 64)+      (BVType 64)+llvmLAbsOverride_64 =+  [llvmOvr| i64 @labs( i64 ) |]+  (\mvar args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args)++llvmLLAbsOverride ::+  (IsSymInterface sym, HasLLVMAnn sym) =>+  LLVMOverride p sym ext+      (EmptyCtx ::> BVType 64)+      (BVType 64)+llvmLLAbsOverride =+  [llvmOvr| i64 @llabs( i64 ) |]+  (\mvar args ->+     do callStack <- callStackFromMemVar' mvar+        Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args)++------------------------------------------------------------------------+-- *** atexit++cxa_atexitOverride+  :: (IsSymInterface sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext+        (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> LLVMPointerType wptr)+        (BVType 32)+cxa_atexitOverride =+  [llvmOvr| i32 @__cxa_atexit( void (i8*)*, i8*, i8* ) |]+  (\_ _args -> do+    sym <- getSymInterface+    liftIO $ bvZero sym knownNat)++------------------------------------------------------------------------+-- ** Implementations++------------------------------------------------------------------------+-- *** Allocation++callRealloc+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> Alignment+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callRealloc mvar alignment (regValue -> ptr) (regValue -> sz) =+  ovrWithBackend $ \bak -> 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+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?lc :: TypeContext, ?memOpts :: MemOptions )+  => 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 mvar (regValue -> outPtr) (regValue -> align) (regValue -> sz) =+  ovrWithBackend $ \bak ->+    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 <- bvZero sym knownNat+                  return (z, mem'')++callMalloc+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> Alignment+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callMalloc mvar alignment (regValue -> sz) =+  ovrWithBackend $ \bak ->+    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+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> Alignment+  -> RegEntry sym (BVType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callCalloc mvar alignment+           (regValue -> sz)+           (regValue -> num) =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $+      doCalloc bak mem sz num alignment++callFree+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret ()+callFree mvar+           (regValue -> ptr) =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $+      do mem' <- doFree bak mem ptr+         return ((), mem')++------------------------------------------------------------------------+-- *** Process control++callExit :: ( IsSymInterface sym+            , ?intrinsicsOpts :: IntrinsicsOptions )+         => RegEntry sym (BVType 32)+         -> OverrideSim p sym ext r args ret (RegValue sym UnitType)+callExit ec =+  ovrWithBackend $ \bak -> liftIO $ do+    let sym = backendGetSym bak+    when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $+      do cond <- bvEq sym (regValue ec) =<< bvZero sym 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++------------------------------------------------------------------------+-- *** Integer functions++-- | 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 ext r args ret.+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  CallStack ->+  CheckAbsIntMin ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callAbs callStack checkIntMin widthRepr (regValue -> src) = do+  sym <- getSymInterface+  ovrWithBackend $ \bak -> liftIO $ do+    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, IsSymInterface sym, HasLLVMAnn sym) =>+  CallStack ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callLibcAbs callStack = callAbs callStack LibcAbsIntMinUB++callLLVMAbs ::+  (1 <= w, IsSymInterface sym, HasLLVMAnn sym) =>+  CallStack ->+  NatRepr w ->+  RegEntry sym (BVType w) ->+  RegEntry sym (BVType 1) ->+  OverrideSim p sym ext r args ret (RegValue sym (BVType w))+callLLVMAbs 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 callStack (LLVMAbsIntMinPoison shouldCheckIntMin) widthRepr src
+ src/Lang/Crucible/LLVM/Intrinsics/Libc/String.hs view
@@ -0,0 +1,443 @@+-- |+-- Module           : Lang.Crucible.LLVM.Intrinsics.Libc.String+-- Description      : Override definitions for C @string.h@ functions+-- Copyright        : (c) Galois, Inc 2026+-- License          : BSD3+-- Maintainer       : Galois, Inc. <crux@galois.com>+-- Stability        : provisional+------------------------------------------------------------------------++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Lang.Crucible.LLVM.Intrinsics.Libc.String+  ( -- * @string.h@ overrides+    stringOverrides+    -- * Override declarations+  , llvmMemcpyOverride+  , llvmMemcpyChkOverride+  , llvmMemmoveOverride+  , llvmMemsetOverride+  , llvmMemsetChkOverride+  , llvmMemcmpOverride+  , llvmStrlenOverride+  , llvmStrnlenOverride+  , llvmStrcpyOverride+  , llvmStrcmpOverride+  , llvmStrncmpOverride+  , llvmStrdupOverride+  , llvmStrndupOverride+    -- * Implementation functions+  , callMemcpy+  , callMemmove+  , callMemset+  , callMemcmp+  , callStrlen+  , callStrnlen+  , callStrcpy+  , callStrcmp+  , callStrncmp+  , callStrdup+  , callStrndup+  ) where++import           Control.Monad.IO.Class (liftIO)+import qualified Data.BitVector.Sized as BV+import           Lens.Micro ((^.), _1, _2, _3)++import           Data.Parameterized.Context ( pattern (:>), pattern Empty )+import qualified Data.Parameterized.Context as Ctx++import           What4.Interface+import           What4.ProgramLoc (plSourceLoc)++import           Lang.Crucible.Backend+import           Lang.Crucible.CFG.Common+import           Lang.Crucible.Types+import           Lang.Crucible.Simulator.OverrideSim+import           Lang.Crucible.Simulator.RegMap+import           Lang.Crucible.Simulator.SimError++import           Lang.Crucible.LLVM.DataLayout+import           Lang.Crucible.LLVM.MemModel+import           Lang.Crucible.LLVM.MemModel.Strings as CStr+import           Lang.Crucible.LLVM.QQ( llvmOvr )++import           Lang.Crucible.LLVM.Intrinsics.Common++-- | All @string.h@ overrides+stringOverrides ::+  ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+  , ?memOpts :: MemOptions ) =>+  [SomeLLVMOverride p sym ext]+stringOverrides =+  [ SomeLLVMOverride llvmMemcpyOverride+  , SomeLLVMOverride llvmMemcpyChkOverride+  , SomeLLVMOverride llvmMemmoveOverride+  , SomeLLVMOverride llvmMemsetOverride+  , SomeLLVMOverride llvmMemsetChkOverride+  , SomeLLVMOverride llvmMemcmpOverride+  , SomeLLVMOverride llvmStrlenOverride+  , SomeLLVMOverride llvmStrnlenOverride+  , SomeLLVMOverride llvmStrcpyOverride+  , SomeLLVMOverride llvmStrcmpOverride+  , SomeLLVMOverride llvmStrncmpOverride+  , SomeLLVMOverride llvmStrdupOverride+  , SomeLLVMOverride llvmStrndupOverride+  ]++------------------------------------------------------------------------+-- ** Declarations++llvmMemcpyOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+           (EmptyCtx ::> LLVMPointerType wptr+                     ::> LLVMPointerType wptr+                     ::> BVType wptr)+           (LLVMPointerType wptr)+llvmMemcpyOverride =+  [llvmOvr| i8* @memcpy( i8*, i8*, size_t ) |]+  (\memOps args ->+       do sym <- getSymInterface+          volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat+          Ctx.uncurryAssignment (callMemcpy memOps)+                                (args :> volatile)+          return $ regValue $ args^._1 -- return first argument+    )+++llvmMemcpyChkOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> LLVMPointerType wptr+                   ::> BVType wptr+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemcpyChkOverride =+  [llvmOvr| i8* @__memcpy_chk ( i8*, i8*, size_t, size_t ) |]+  (\memOps args ->+      do let args' = Empty :> (args^._1) :> (args^._2) :> (args^._3)+         sym <- getSymInterface+         volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat+         Ctx.uncurryAssignment (callMemcpy memOps)+                               (args' :> volatile)+         return $ regValue $ args^._1 -- return first argument+    )++llvmMemmoveOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext+         (EmptyCtx ::> (LLVMPointerType wptr)+                   ::> (LLVMPointerType wptr)+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemmoveOverride =+  [llvmOvr| i8* @memmove( i8*, i8*, size_t ) |]+  (\memOps args ->+      do sym <- getSymInterface+         volatile <- liftIO (RegEntry knownRepr <$> bvZero sym knownNat)+         Ctx.uncurryAssignment (callMemmove memOps)+                               (args :> volatile)+         return $ regValue $ args^._1 -- return first argument+    )++llvmMemsetOverride :: forall p sym ext wptr.+     (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr+                   ::> BVType 32+                   ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemsetOverride =+  [llvmOvr| i8* @memset( i8*, i32, size_t ) |]+  (\memOps args ->+      do sym <- getSymInterface+         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 <$> bvZero sym knownNat)+         callMemset memOps dest val len volatile+         return (regValue dest)+    )++llvmMemsetChkOverride+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => LLVMOverride p sym ext+         (EmptyCtx ::> LLVMPointerType wptr+                 ::> BVType 32+                 ::> BVType wptr+                 ::> BVType wptr)+         (LLVMPointerType wptr)+llvmMemsetChkOverride =+  [llvmOvr| i8* @__memset_chk( i8*, i32, size_t, size_t ) |]+  (\memOps args ->+      do sym <- getSymInterface+         let dest = args^._1+         val <- liftIO+              (RegEntry knownRepr <$> bvTrunc sym knownNat (regValue (args^._2)))+         let len = args^._3+         volatile <- liftIO+            (RegEntry knownRepr <$> bvZero sym knownNat)+         callMemset memOps dest val len volatile+         return (regValue dest)+    )++llvmStrlenOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType wptr)+llvmStrlenOverride =+  [llvmOvr| size_t @strlen( i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrlen memOps) args)++llvmStrnlenOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr) (BVType wptr)+llvmStrnlenOverride =+  [llvmOvr| size_t @strnlen( i8*, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrnlen memOps) args)++llvmStrcpyOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr) (LLVMPointerType wptr)+llvmStrcpyOverride =+  [llvmOvr| i8* @strcpy( i8*, i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrcpy memOps) args)++llvmStrdupOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (LLVMPointerType wptr)+llvmStrdupOverride =+  [llvmOvr| i8* @strdup( i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrdup memOps) args)++llvmStrndupOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr) (LLVMPointerType wptr)+llvmStrndupOverride =+  [llvmOvr| i8* @strndup( i8*, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrndup memOps) args)++llvmMemcmpOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> BVType wptr) (BVType 32)+llvmMemcmpOverride =+  [llvmOvr| i32 @memcmp( i8*, i8*, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callMemcmp memOps) args)++llvmStrcmpOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr) (BVType 32)+llvmStrcmpOverride =+  [llvmOvr| i32 @strcmp( i8*, i8* ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrcmp memOps) args)++llvmStrncmpOverride+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> BVType wptr) (BVType 32)+llvmStrncmpOverride =+  [llvmOvr| i32 @strncmp( i8*, i8*, size_t ) |]+  (\memOps args -> Ctx.uncurryAssignment (callStrncmp memOps) args)++------------------------------------------------------------------------+-- ** Implementations++------------------------------------------------------------------------+-- *** Memory manipulation++callMemcpy+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => 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 mvar+           (regValue -> dest)+           (regValue -> src)+           (RegEntry (BVRepr w) len)+           _volatile =+  ovrWithBackend $ \bak ->+    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+  :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr+     , ?memOpts :: MemOptions )+  => 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 mvar+           (regValue -> dest)+           (regValue -> src)+           (RegEntry (BVRepr w) len)+           _volatile =+  -- FIXME? add assertions about alignment+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $+      do mem' <- doMemcpy bak w mem False dest src len+         return ((), mem')++callMemset+  :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr)+  => 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 mvar+           (regValue -> dest)+           (regValue -> val)+           (RegEntry (BVRepr w) len)+           _volatile =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $+      do mem' <- doMemset bak w mem dest val len+         return ((), mem')++------------------------------------------------------------------------+-- *** Strings++callStrlen+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr))+callStrlen mvar (regValue -> strPtr) =+  ovrWithBackend $ \bak -> do+    mem <- readGlobal mvar+    liftIO $ strLen bak mem strPtr++callStrnlen+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr))+callStrnlen mvar (regValue -> strPtr) (regValue -> bound) =+  ovrWithBackend $ \bak -> do+    mem <- readGlobal mvar+    liftIO $ CStr.strnlen bak mem strPtr bound++callStrcpy+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callStrcpy mvar (regValue -> dst) (regValue -> src) =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> do+      mem' <- liftIO $ CStr.copyConcretelyNullTerminatedString bak mem dst src Nothing+      pure (dst, mem')++callStrdup+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callStrdup mvar (regValue -> src) =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $ do+      let sym = backendGetSym bak+      loc <- plSourceLoc <$> getCurrentProgramLoc sym+      let loc' = "<strdup> " ++ show loc+      CStr.dupConcretelyNullTerminatedString bak mem src Nothing loc' noAlignment++callStrndup+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr))+callStrndup mvar (regValue -> src) (regValue -> bound) =+  ovrWithBackend $ \bak ->+    modifyGlobal mvar $ \mem -> liftIO $ do+      let sym = backendGetSym bak+      loc <- plSourceLoc <$> getCurrentProgramLoc sym+      let loc' = "<strndup> " ++ show loc+      case BV.asUnsigned <$> asBV bound of+        Nothing -> do+          let err = AssertFailureSimError "`strndup` called with symbolic max length" ""+          addFailedAssertion bak err+        Just b ->+          let bound' = Just (fromIntegral b) in+          CStr.dupConcretelyNullTerminatedString bak mem src bound' loc' noAlignment++callMemcmp+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callMemcmp mvar (regValue -> ptr1) (regValue -> ptr2) (regValue -> len) =+  ovrWithBackend $ \bak -> do+    mem <- readGlobal mvar+    liftIO $ CStr.memcmp bak mem ptr1 ptr2 len++callStrcmp+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callStrcmp mvar (regValue -> ptr1) (regValue -> ptr2) =+  ovrWithBackend $ \bak -> do+    mem <- readGlobal mvar+    liftIO $ CStr.cmpConcretelyNullTerminatedString bak mem ptr1 ptr2 Nothing++callStrncmp+  :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym+     , ?memOpts :: MemOptions )+  => GlobalVar Mem+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (LLVMPointerType wptr)+  -> RegEntry sym (BVType wptr)+  -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32))+callStrncmp mvar (regValue -> ptr1) (regValue -> ptr2) (regValue -> len) =+  ovrWithBackend $ \bak -> do+    mem <- readGlobal mvar+    liftIO $ CStr.strncmp bak mem ptr1 ptr2 len
src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs view
@@ -35,7 +35,6 @@   ) where  import qualified ABI.Itanium as ABI-import           Control.Lens ((^.)) import           Control.Monad.Reader import           Data.List (isInfixOf) import           Data.Type.Equality ((:~:)(Refl), testEquality)@@ -49,17 +48,17 @@  import           Lang.Crucible.Backend import           Lang.Crucible.CFG.Common (GlobalVar)-import           Lang.Crucible.Simulator.OverrideSim (getSymInterface)-import           Lang.Crucible.Simulator.RegMap (RegValue, regValue)+import           Lang.Crucible.Simulator.OverrideSim (OverrideSim, getSymInterface)+import           Lang.Crucible.Simulator.RegMap (RegEntry, RegValue, regValue) import           Lang.Crucible.Panic (panic)-import           Lang.Crucible.Types (TypeRepr(UnitRepr), CtxRepr)+import           Lang.Crucible.Types (TypeRepr(UnitRepr))  import           Lang.Crucible.LLVM.Extension import           Lang.Crucible.LLVM.Intrinsics.Common+import qualified Lang.Crucible.LLVM.Intrinsics.Declare as Decl import qualified Lang.Crucible.LLVM.Intrinsics.Match as Match import           Lang.Crucible.LLVM.MemModel-import           Lang.Crucible.LLVM.Translation.Monad-import           Lang.Crucible.LLVM.Translation.Types+import           Lang.Crucible.LLVM.Translation.Monad (LLVMContext)  ------------------------------------------------------------------------ -- ** General@@ -86,7 +85,11 @@ data SomeCPPOverride p sym arch =   SomeCPPOverride   { cppOverrideSubstrings :: [String]-  , cppOverrideAction :: L.Declare -> ABI.DecodedName -> LLVMContext arch -> Maybe (SomeLLVMOverride p sym LLVM)+  , cppOverrideAction ::+      Decl.SomeDeclare ->+      ABI.DecodedName ->+      LLVMContext arch ->+      Maybe (SomeLLVMOverride p sym LLVM)   }  ------------------------------------------------------------------------@@ -96,56 +99,68 @@ -- *** Utilities  matchSymbolName :: (L.Symbol -> ABI.DecodedName -> Bool)-                -> L.Declare+                -> Decl.SomeDeclare                 -> ABI.DecodedName                 -> Maybe a                 -> Maybe a-matchSymbolName match decl decodedName =-  if not (match (L.decName decl) decodedName)+matchSymbolName match (Decl.SomeDeclare decl) decodedName =+  if not (match (Decl.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_ :: String -> Decl.SomeDeclare -> c+panic_ from (Decl.SomeDeclare decl) =   panic from [ "Ill-typed override"              , "Name: " ++ nm-             , "Args: " ++ show args-             , "Ret:  " ++ show ret+             , "Args: " ++ show (Decl.decArgs decl)+             , "Ret:  " ++ show (Decl.decRet decl)              ]-  where L.Symbol nm = L.decName decl+  where L.Symbol nm = Decl.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 LLVM))+           -> (Decl.SomeDeclare -> Maybe (SomeLLVMOverride p sym LLVM))            -> (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+  SomeCPPOverride substrings $ \requestedDecl decodedName _llvmCtx ->+    matchSymbolName filt requestedDecl decodedName (ov requestedDecl)  ------------------------------------------------------------------------ -- *** No-op override builders +someOv ::+  L.Symbol ->+  Ctx.Assignment TypeRepr args ->+  TypeRepr ret ->+  (IsSymInterface sym =>+    GlobalVar Mem ->+    Ctx.Assignment (RegEntry sym) args ->+    forall rtp args' ret'.+    OverrideSim p sym ext rtp args' ret' (RegValue sym ret)) ->+  SomeLLVMOverride p sym ext+someOv nm argTys retTy def =+  SomeLLVMOverride (LLVMOverride (Decl.Declare nm argTys retTy) def)+ -- | 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 _args -> pure ()-        _ -> panic_ "voidOverride" decl argTys retTy+  mkOverride substrings $+    \sd@(Decl.SomeDeclare+          (Decl.Declare+          { Decl.decName = nm+          , Decl.decArgs = argTys+          , Decl.decRet = retTy+          })) ->+      Just $+        case retTy of+          UnitRepr -> someOv nm argTys retTy $ \_mem _args -> pure ()+          _ -> panic_ "voidOverride" sd  -- | Make an override for a function of (LLVM) type @a -> a@, for any @a@. --@@ -155,15 +170,22 @@                  -> (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 args ->-              -- Just return the input-              pure (Ctx.uncurryAssignment regValue args)+  mkOverride substrings $+    \sd@(Decl.SomeDeclare+          (Decl.Declare+          { Decl.decName = nm+          , Decl.decArgs = argTys+          , Decl.decRet = retTy+          })) ->+      Just $+        case argTys of+          (Ctx.Empty Ctx.:> argTy)+            | Just Refl <- testEquality argTy retTy ->+                someOv nm argTys retTy $ \_mem args ->+                  -- Just return the input+                  pure (Ctx.uncurryAssignment regValue args) -      _ -> panic_ "identityOverride" decl argTys retTy+          _ -> panic_ "identityOverride" sd  -- | Make an override for a function of (LLVM) type @a -> b -> a@, for any @a@. --@@ -173,14 +195,21 @@               -> (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 args ->-          pure (Ctx.uncurryAssignment (const . regValue) args)+  mkOverride substrings $+    \sd@(Decl.SomeDeclare+          (Decl.Declare+          { Decl.decName = nm+          , Decl.decArgs = argTys+          , Decl.decRet = retTy+          })) ->+      Just $+        case argTys of+          (Ctx.Empty Ctx.:> fstTy Ctx.:> _)+            | Just Refl <- testEquality fstTy retTy ->+            someOv nm argTys retTy $ \_mem args ->+              pure (Ctx.uncurryAssignment (const . regValue) args) -      _ -> panic_ "constOverride" decl argTys retTy+          _ -> panic_ "constOverride" sd  -- | Make an override that always returns the same value. fixedOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)@@ -190,14 +219,21 @@               -> (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 _args -> do-          sym <- getSymInterface-          liftIO (regval mem sym)+  mkOverride substrings $+    \sd@(Decl.SomeDeclare+          (Decl.Declare+          { Decl.decName = nm+          , Decl.decArgs = argTys+          , Decl.decRet = retTy+          })) ->+      Just $+        case testEquality retTy ty of+          Just Refl ->+            someOv nm argTys retTy $ \mem _args -> do+              sym <- getSymInterface+              liftIO (regval mem sym) -      _ -> panic_ "fixedOverride" decl argTys retTy+          _ -> panic_ "fixedOverride" sd  -- | Return @true@. trueOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch)
src/Lang/Crucible/LLVM/MemModel.hs view
@@ -46,6 +46,8 @@   , IndeterminateLoadBehavior(..)   , defaultMemOptions   , laxPointerMemOptions+  , ppLLVMMemIntrinsicType+  , ppLLVMIntrinsicTypes    -- * Pointers   , LLVMPointerType@@ -83,9 +85,15 @@   , doArrayStoreUnbounded   , doArrayConstStore   , doArrayConstStoreUnbounded-  , loadString-  , loadMaybeString-  , strLen+  -- TODO(#1308): When GHC 9.6 support is dropped, deprecate these imports+  -- TOOD(#1406): After they have been deprecated for a while, move the+  -- implementations to `Strings` and remove these exports.+  , -- {-# DEPRECATED "Exported from Crucible.LLVM.MemModel.Strings instead" #-}+    loadString+  , -- {-# DEPRECATED "Exported from Crucible.LLVM.MemModel.Strings instead" #-}+    loadMaybeString+  , -- {-# DEPRECATED "Exported from Crucible.LLVM.MemModel.Strings instead" #-}+    strLen   , uncheckedMemcpy      -- * \"Raw\" operations with LLVMVal@@ -189,12 +197,10 @@  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@@ -202,7 +208,10 @@ import           Data.Text (Text) import           Data.Word import qualified GHC.Stack as GHC+import           Lens.Micro ((^.), _2, to, folded)+import           Lens.Micro.Mtl (use, (%=)) import           Numeric.Natural (Natural)+import qualified Prettyprinter as PP import           System.IO (Handle, hPutStrLn)  import qualified Data.BitVector.Sized as BV@@ -270,7 +279,7 @@   { memImplBlockSource :: BlockSource   , memImplGlobalMap   :: GlobalMap sym   , memImplSymbolMap   :: Map Natural L.Symbol -- inverse mapping to 'memImplGlobalMap'-  , memImplHandleMap   :: Map Natural Dynamic+  , memImplHandleMap   :: Map Natural SomeFnHandle   , memImplHeap        :: G.Mem sym   } @@ -353,6 +362,34 @@         --putStrLn "MEM ABORT BRANCH"         return $ MemImpl nxt gMap sMap hMap $ G.branchAbortMem m +-- | An intrinsic-printing function for 'MemImpl' for use with+-- 'Lang.Crucible.Types.ppTypeRepr'.+ppLLVMMemIntrinsicType ::+  Applicative f =>+  -- | Fallback for other instrinsics, can be+  -- 'Lang.Crucible.Types.ppIntrinsicDefault'.+  (forall s ctx'. SymbolRepr s -> CtxRepr ctx' -> f (PP.Doc ann)) ->+  SymbolRepr symb ->+  CtxRepr ctx ->+  f (PP.Doc ann)+ppLLVMMemIntrinsicType fallback symbRepr tyCtx =+  case testEquality symbRepr (knownSymbol @"LLVM_memory") of+    Nothing -> fallback symbRepr tyCtx+    Just Refl -> pure "LLVMMemory"++-- | An intrinsic-printing function for the LLVM intrinsic types for use with+-- 'Lang.Crucible.Types.ppTypeRepr'.+ppLLVMIntrinsicTypes ::+  Applicative f =>+  -- | Fallback for other instrinsics, can be+  -- 'Lang.Crucible.Types.ppIntrinsicDefault'.+  (forall s ctx'. SymbolRepr s -> CtxRepr ctx' -> f (PP.Doc ann)) ->+  SymbolRepr symb ->+  CtxRepr ctx ->+  f (PP.Doc ann)+ppLLVMIntrinsicTypes fallback =+  ppLLVMMemIntrinsicType (ppLLVMPointerIntrinsicType fallback)+ -- | Top-level evaluation function for LLVM extension statements. --   LLVM extension statements are used to implement the memory model operations. llvmStatementExec ::@@ -444,7 +481,10 @@            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)))+                let estr = "Failed to load function handle: "+                           <> fromMaybe "<unidentified>" gsym+                let err = SimError loc (AssertFailureSimError estr+                                        (show (ME.ppFuncLookupError lookupErr)))                 addProofObligation bak (LabeledPred p err)                 abortExecBecause (AssertionFailure err) @@ -527,9 +567,7 @@     do mem <- getMem mvar        liftIO $ doPtrSubtract bak mem x y -  eval LLVM_Debug{} = pure () - mkMemVar :: Text          -> HandleAllocator          -> IO (GlobalVar Mem)@@ -713,16 +751,16 @@ -- -- See also "Lang.Crucible.LLVM.Functions". doInstallHandle-  :: (Typeable a, IsSymBackend sym bak)+  :: IsSymBackend sym bak   => bak   -> LLVMPtr sym wptr-  -> a {- ^ handle -}+  -> SomeFnHandle   -> MemImpl sym   -> IO (MemImpl sym)-doInstallHandle _bak ptr x mem =+doInstallHandle _bak ptr hdl mem =   case asNat (llvmPointerBlock ptr) of     Just blkNum ->-      do let hMap' = Map.insert blkNum (toDyn x) (memImplHandleMap mem)+      do let hMap' = Map.insert blkNum hdl (memImplHandleMap mem)          return mem{ memImplHandleMap = hMap' }     Nothing ->       panic "MemModel.doInstallHandle"@@ -732,11 +770,11 @@  -- | Look up the handle associated with the given pointer, if any. doLookupHandle-  :: (Typeable a, IsSymInterface sym)+  :: IsSymInterface sym   => sym   -> MemImpl sym   -> LLVMPtr sym wptr-  -> IO (Either ME.FuncLookupError a)+  -> IO (Either ME.FuncLookupError SomeFnHandle) doLookupHandle _sym mem ptr = do   let LLVMPointer blk _ = ptr   case asNat blk of@@ -746,10 +784,7 @@       | 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)+            Just hdl -> return (Right hdl)  -- | Free the memory region pointed to by the given pointer. --@@ -1558,6 +1593,13 @@     , "*** Undef value: " ++ show v     ] +unpackMemValue _ tpr v@(LLVMValPoison _) =+  panic "MemModel.unpackMemValue"+    [ "Cannot unpack a `poison` value"+    , "*** Crucible type: " ++ show tpr+    , "*** Poison value: " ++ show v+    ]+ unpackMemValue _ tpr v =   panic "MemModel.unpackMemValue"     [ "Crucible type mismatch when unpacking LLVM value"@@ -1770,6 +1812,8 @@   LLVMValZero <$> toStorableType memty constToLLVMValP _sym _look (UndefConst memty) = liftIO $   LLVMValUndef <$> toStorableType memty+constToLLVMValP _sym _look (PoisonConst memty) = liftIO $+  LLVMValPoison <$> toStorableType memty   -- | Translate a constant into an LLVM runtime value. Assumes all necessary
src/Lang/Crucible/LLVM/MemModel/Common.hs view
@@ -49,13 +49,14 @@   ) 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 Lens.Micro ((^.))+import Lens.Micro.Extras (view) import Numeric.Natural  import Lang.Crucible.Panic ( panic )@@ -454,9 +455,9 @@ 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 stp = fromMaybe (panic "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')+        where etp = fromMaybe (panic "loadBitvector.retValue" ["bad view", show v']) (viewType v')               esz = storageTypeSize etp               lo' = max lo eo               sz' = min le (eo+esz) - lo'@@ -467,8 +468,10 @@         let d = lo - so         -- Store is before load.         valueLoad lo ltp lo (SelectSuffixBV d (sw - d) v)-      | otherwise -> assert (lo == so && lw < sw) $+      | otherwise ->+        -- TODO(#1560): This assertion can fail.         -- Load ends before store ends.+        -- assert (lo == so && lw < sw) $         valueLoad lo ltp so (SelectPrefixBV lw (sw - lw) v)     Float -> valueLoad lo ltp so (FloatToBV v)     Double -> valueLoad lo ltp so (DoubleToBV v)@@ -511,8 +514,10 @@   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+  -- The non-zero test ensures that 0-byte loads are always overlapping+  -- with the most recent store so that they're not spuriously rejected.+  | le <= so && nonZeroLoad = ValueCtorVar (OldMemory lo ltp) -- Load ends before store+  | se <= lo && nonZeroLoad = 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.@@ -531,9 +536,10 @@       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)+ where stp = fromMaybe (panic "coerceValue" ["given bad view", show v]) (viewType v)        le = typeEnd lo ltp        se = so + storageTypeSize stp+       nonZeroLoad = le - lo > 0  -- | @LinearLoadStoreOffsetDiff stride delta@ represents the fact that --   the difference between the load offset and the store offset is
src/Lang/Crucible/LLVM/MemModel/Generic.hs view
@@ -76,10 +76,11 @@  import           Prelude hiding (pred) -import           Control.Lens+import qualified Control.Exception as X import           Control.Monad import           Control.Monad.State.Strict import           Control.Monad.Trans.Maybe+import           Data.Function ((&)) import           Data.IORef import           Data.Maybe import qualified Data.List as List@@ -88,9 +89,11 @@ import qualified Data.IntMap as IntMap import           Data.Monoid import           Data.Text (Text)+import           Lens.Micro ((^.), (.~), (%~)) import           Numeric.Natural import           Prettyprinter import           Lang.Crucible.Panic (panic)+import qualified Data.Vector as V  import           Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV@@ -695,6 +698,21 @@       | otherwise       = liftIO (Partial.partErr sym mop $ Invalidated msg) +-- | Construct a value of a type that has no in-memory representation at all+buildEmptyVal :: StorageType -> Maybe (LLVMVal sym)+buildEmptyVal t =+  case storageTypeF t of+    Struct fields   -> LLVMValStruct <$> traverse emptyStorageField fields+    Array n eltTy+      | n == 0      -> Just (LLVMValArray eltTy V.empty)+      | otherwise   -> LLVMValArray eltTy . V.replicate (fromIntegral n) <$> buildEmptyVal eltTy+    X86_FP80        -> Nothing+    Float           -> Nothing+    Double          -> Nothing+    Bitvector {}    -> Nothing -- Bitvectors can't be empty; they have a non-zero size invariant+  where+    emptyStorageField field = (,) field <$> buildEmptyVal (field ^. fieldVal)+ -- | Read a value from memory. readMem :: forall sym w.   ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym@@ -707,6 +725,12 @@   Alignment ->   Mem sym ->   IO (PartLLVMVal sym)+readMem sym _ _ _ tp _ _+  -- no actual memory read happens when reading a value with+  -- no memory representation. This check comes up in+  -- particular when evaluating llvm_points_to statements+  -- in SAW script.+  | Just v <- buildEmptyVal tp = pure (Partial.totalLLVMVal sym v) 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@@ -1555,7 +1579,7 @@           BranchFrame (sizeMemAllocs (fst c)) wc c $ popf s           where c = (popMemAllocs a, w) -        popf EmptyMem{} = error "popStackFrameMem given unexpected memory"+        popf EmptyMem{} = panic "popStackFrameMem" ["given unexpected memory"]   -- | Free a heap-allocated block of memory.@@ -1584,22 +1608,44 @@     isHeapMutable (AllocInfo HeapAlloc _ Mutable _ _) = pure (truePred sym)     isHeapMutable _ = pure (falsePred sym) +-- | Prepare memory so that it can later be merged via 'mergeMem'.+--+-- This is primarily intended for use in the implementation of+-- 'Lang.Crucible.Simulator.Intrinsics.pushBranchIntrinsic' for LLVM memory.+-- It would be nice to remove this someday, see #890.+--+-- For more information about branching and merging, see the comment on 'Mem'. branchMem :: Mem sym -> Mem sym branchMem = memState %~ \s ->   BranchFrame (memStateAllocCount s) (memStateWriteCount s) emptyChanges s +-- | Remove the top 'BranchFrame', adding changes to the underlying memory.+--+-- This is primarily intended for use in the implementation of+-- 'Lang.Crucible.Simulator.Intrinsics.abortBranchIntrinsic' for LLVM memory. branchAbortMem :: Mem sym -> Mem sym branchAbortMem = memState %~ popf   where popf (BranchFrame _ _ c s) = s & memStateAddChanges c-        popf _ = error "branchAbortMem given unexpected memory"+        popf _ = panic "branchAbortMem" ["given unexpected memory"] +-- | Merge memory that was previously prepared via 'branchMem'.+--+-- This is primarily intended for use in the implementation of+-- 'Lang.Crucible.Simulator.Intrinsics.muxIntrinsic' for LLVM memory.+--+-- For more information about branching and merging, see the comment on 'Mem'. 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"+    (BranchFrame _ _ a s, BranchFrame _ _ b s') ->+      -- The memories to be merged must have originated from the same memory,+      -- and in particular, should have matching alloc/write counts.+      let allocsEq = memStateAllocCount s == memStateAllocCount s' in+      let writesEq = memStateWriteCount s == memStateWriteCount s' in+      X.assert (allocsEq && writesEq) $+        let s' = s & memStateAddChanges (muxChanges c a b)+        in x & memState .~ s'+    _ -> panic "mergeMem" ["given unexpected memories"]  -------------------------------------------------------------------------------- -- Finding allocations
src/Lang/Crucible/LLVM/MemModel/MemLog.hs view
@@ -79,10 +79,10 @@   ) where  import           Control.Applicative ((<|>))-import           Control.Lens import           Control.Monad.State import           Control.Monad.Trans.Maybe import           Data.Foldable+import           Data.Function ((&)) import           Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.List.Extra as List@@ -92,6 +92,7 @@ import           Data.Set (Set) import qualified Data.Set as Set import           Data.Text (Text)+import           Lens.Micro (Lens', lens, (^.), (.~)) import           Numeric.Natural import           Prettyprinter @@ -344,8 +345,12 @@     -- 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.+    --+    -- For more information about branching and merging, see the comment on+    -- 'Mem'.   | BranchFrame !Int !Int (MemChanges sym) (MemState sym)  type MemChanges sym = (MemAllocs sym, MemWrites sym)@@ -672,7 +677,9 @@ 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?+  pure (LLVMValUndef st)+concLLVMVal _ _ (LLVMValPoison st) =+  pure (LLVMValPoison st)   concWriteSource ::
src/Lang/Crucible/LLVM/MemModel/Partial.hs view
@@ -67,7 +67,6 @@  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)@@ -78,6 +77,8 @@ import qualified Data.Map as Map import           Data.Vector (Vector) import qualified Data.Vector as V+import           Lens.Micro ((^.))+import           Lens.Micro.Extras (view) import           Numeric.Natural  import qualified Data.BitVector.Sized as BV@@ -129,13 +130,14 @@   x <> NoExplanation = x   DisjOfFailures xs <> DisjOfFailures ys = DisjOfFailures (xs ++ ys) -explainCex :: forall t st fs sym.-  (IsSymInterface sym, sym ~ ExprBuilder t st fs) =>+explainCex :: forall t st fm sym.+  (IsSymInterface sym, sym ~ ExprBuilder t st (Flags fm)) =>   sym ->+  FloatModeRepr fm ->   LLVMAnnMap sym ->   Maybe (GroundEvalFn t) ->   IO (Pred sym -> IO (CexExplanation sym BaseBoolType))-explainCex sym bbMap evalFn =+explainCex sym fm bbMap evalFn =   do posCache <- newIdxCache      negCache <- newIdxCache      pure (evalPos posCache negCache)@@ -154,7 +156,7 @@           Nothing -> evalPos posCache negCache e'           Just (callStack, bb) ->             do bb' <- case evalFn of-                        Just f  -> concBadBehavior sym (groundEval f) bb+                        Just f  -> concBadBehavior sym fm (groundEval f) bb                         Nothing -> pure bb                pure (DisjOfFailures [ (callStack, bb') ]) @@ -381,6 +383,9 @@ floatToBV _ _ (NoErr p (LLVMValUndef (StorageType Float _))) =   return (NoErr p (LLVMValUndef (Type.bitvectorType 4))) +floatToBV _ _ (NoErr p (LLVMValPoison (StorageType Float _))) =+  return (NoErr p (LLVMValPoison (Type.bitvectorType 4)))+ floatToBV sym _ (NoErr p (LLVMValZero (StorageType Float _))) =   do nz <- W4I.natLit sym 0      iz <- W4I.bvZero sym (knownNat @32)@@ -407,6 +412,9 @@ doubleToBV _ _ (NoErr p (LLVMValUndef (StorageType Double _))) =   return (NoErr p (LLVMValUndef (Type.bitvectorType 8))) +doubleToBV _ _ (NoErr p (LLVMValPoison (StorageType Double _))) =+  return (NoErr p (LLVMValPoison (Type.bitvectorType 8)))+ doubleToBV sym _ (NoErr p (LLVMValZero (StorageType Double _))) =   do nz <- W4I.natLit sym 0      iz <- W4I.bvZero sym (knownNat @64)@@ -433,6 +441,9 @@ fp80ToBV _ _ (NoErr p (LLVMValUndef (StorageType X86_FP80 _))) =   return (NoErr p (LLVMValUndef (Type.bitvectorType 10))) +fp80ToBV _ _ (NoErr p (LLVMValPoison (StorageType X86_FP80 _))) =+  return (NoErr p (LLVMValPoison (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)@@ -937,6 +948,12 @@                                           , "Undef type: " ++ show tpu                                           ] +      LLVMValPoison tpp ->+        -- TODO: Is this the right behavior?+        panic "Cannot mux zero and poison" [ "Zero type: " ++ show tpz+                                           , "Poison type: " ++ show tpp+                                           ]+       LLVMValString bs -> muxzero cond tpz =<< Value.explodeStringValue sym bs        LLVMValInt base off ->@@ -1007,6 +1024,9 @@           LLVMValArray tp1 <$> V.zipWithM (muxval cond) v1 v2      muxval _ v1@(LLVMValUndef tp1) (LLVMValUndef tp2)+      | tp1 == tp2 = pure v1++    muxval _ v1@(LLVMValPoison tp1) (LLVMValPoison tp2)       | tp1 == tp2 = pure v1      muxval _ v1 v2 =
src/Lang/Crucible/LLVM/MemModel/Pointer.hs view
@@ -78,6 +78,7 @@      -- * Pretty printing   , ppPtr+  , ppLLVMPointerIntrinsicType      -- * Annotation   , annotatePointerBlock@@ -89,6 +90,7 @@ import qualified Data.Map as Map (lookup) import           Numeric.Natural import           Prettyprinter+import qualified Prettyprinter as PP  import           GHC.TypeLits (TypeError, ErrorMessage(..)) import           GHC.TypeNats@@ -102,7 +104,6 @@  import qualified What4.Expr.GroundEval as W4GE import           What4.Interface-import           What4.InterpretedFloatingPoint import           What4.Expr (GroundValue)  import           Lang.Crucible.Backend@@ -250,10 +251,14 @@        panic "LLVM.MemModel.Pointer.concPtrFn"          [ "Impossible: LLVMPointerType ill-formed context" ] +-- | Helper, not exported+ptrSymb :: SymbolRepr "LLVM_pointer"+ptrSymb = knownSymbol+ -- | A singleton map suitable for use in a 'Conc.ConcCtx' if LLVM pointers are -- the only intrinsic type in use concPtrFnMap :: MapF.MapF SymbolRepr (Conc.IntrinsicConcFn t)-concPtrFnMap = MapF.singleton (knownSymbol @"LLVM_pointer") concPtrFn+concPtrFnMap = MapF.singleton ptrSymb concPtrFn  -- | A 'Conc.IntrinsicConcToSymFn' for LLVM pointers concToSymPtrFn :: Conc.IntrinsicConcToSymFn "LLVM_pointer"@@ -272,7 +277,7 @@ -- | A singleton map suitable for use in 'Crucible.Concretize.concToSym' if LLVM -- pointers are the only intrinsic type in use concToSymPtrFnMap :: MapF.MapF SymbolRepr Conc.IntrinsicConcToSymFn-concToSymPtrFnMap = MapF.singleton (knownSymbol @"LLVM_pointer") concToSymPtrFn+concToSymPtrFnMap = MapF.singleton ptrSymb concToSymPtrFn  -- | Mux function specialized to LLVM pointer values. muxLLVMPtr ::@@ -288,21 +293,6 @@      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)@@ -424,6 +414,33 @@      let blk_doc = printSymNat blk          off_doc = printSymExpr bv       in pretty "(" <> blk_doc <> pretty "," <+> off_doc <> pretty ")"++-- | An intrinsic-printing function for use with+-- 'Lang.Crucible.Types.ppTypeRepr'.+ppLLVMPointerIntrinsicType ::+  Applicative f =>+  -- | Fallback for other instrinsics, can be+  -- 'Lang.Crucible.Types.ppIntrinsicDefault'.+  (forall s ctx'. SymbolRepr s -> CtxRepr ctx' -> f (PP.Doc ann)) ->+  SymbolRepr symb ->+  CtxRepr ctx ->+  f (PP.Doc ann)+ppLLVMPointerIntrinsicType fallback symbRepr tyCtx =+  case testEquality symbRepr ptrSymb of+    Nothing -> fallback symbRepr tyCtx+    Just Refl ->+      case Ctx.viewAssign tyCtx of+        Ctx.AssignExtend (Ctx.viewAssign -> Ctx.AssignEmpty) (BVRepr w) ->+          pure (PP.pretty "(Ptr" PP.<+> PP.viaShow w <> PP.pretty ")")+        -- These are impossible by the definition of LLVMPointerImpl+        Ctx.AssignEmpty ->+          panic+          "ppLLVMPointerIntrinsicType"+          ["Impossible: LLVMPointerType empty context"]+        Ctx.AssignExtend _ _ ->+          panic+          "ppLLVMPointerIntrinsicType"+          ["Impossible: LLVMPointerType ill-formed context"]  -- | Look up a pointer in the 'memImplGlobalMap' to see if it's a global. --
+ src/Lang/Crucible/LLVM/MemModel/Strings.hs view
@@ -0,0 +1,1486 @@+-- TODO(#1406): Move the definitions of the deprecated imports into this module,+-- and remove the exports from MemModel.+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | Manipulating C-style null-terminated strings+module Lang.Crucible.LLVM.MemModel.Strings+  ( storeString+  -- * Loading strings+  , Mem.loadString+  , Mem.loadMaybeString+  , loadConcretelyNullTerminatedString+  , loadProvablyNullTerminatedString+  -- * String length+  , Mem.strLen+  , strnlen+  , strlenConcreteString+  , strlenConcretelyNullTerminatedString+  , strlenProvablyNullTerminatedString+  -- * String copying+  , copyConcreteString+  , copyConcretelyNullTerminatedString+  , copyProvablyNullTerminatedString+  -- * String duplication+  , dupConcreteString+  , dupConcretelyNullTerminatedString+  , dupProvablyNullTerminatedString+  -- * Memory comparison+  , memcmp+  , memcmpConcreteLen+  -- * String comparison+  , strncmp+  , strncmpConcreteLen+  , cmpConcreteString+  , cmpConcretelyNullTerminatedString+  , cmpProvablyNullTerminatedString+  -- * Low-level string loading primitives+  -- ** 'ByteChecker'+  , ControlFlow(..)+  , ByteChecker(..)+  , withMaxChars+  -- *** For loading strings+  , fullyConcreteNullTerminatedString+  , concretelyNullTerminatedString+  , provablyNullTerminatedString+  -- *** For string length+  , fullyConcreteNullTerminatedStringLength+  , concretelyNullTerminatedStringLength+  , provablyNullTerminatedStringLength+  -- ** 'ByteLoader'+  , ByteLoader(..)+  , llvmByteLoader+  -- * 'loadBytes'+  , loadBytes+  -- * Loading and checking two byte streams+  -- ** 'BytesLoader'+  , BytesLoader(..)+  , llvmBytesLoader+  , llvmStringsLoader+  -- ** 'BytesChecker'+  , BytesChecker(..)+  , withMaxBytes+  -- ** 'loadTwoBytes'+  , loadTwoBytes+  -- ** 'BytesChecker's for string comparison+  , fullyConcreteNullTerminatedStrings+  , concretelyNullTerminatedStrings+  , provablyNullTerminatedStrings+  , lengthBoundedStringComparison+  , lengthBoundedProvablyNullTerminatedStringComparison+  -- ** 'BytesChecker's for length-bounded comparison+  , simpleByteComparison+  , lengthBoundedByteComparison+  ) where++import           Data.Bifunctor (Bifunctor(bimap))++import           Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.State.Strict as State+import qualified Data.BitVector.Sized as BV+import           Data.Functor ((<&>))+import           Lens.Micro ((^.), to)+import qualified Data.Parameterized.NatRepr as DPN+import           Data.Word (Word8)+import qualified Data.Vector as Vec+import qualified GHC.Stack as GHC+import qualified Lang.Crucible.Backend as LCB+import qualified Lang.Crucible.Backend.Online as LCBO+import qualified Lang.Crucible.Simulator as LCS+import qualified Lang.Crucible.LLVM.DataLayout as CLD+import qualified Lang.Crucible.LLVM.Errors.MemoryError as MemErr+import qualified Lang.Crucible.LLVM.MemModel as LCLM+import qualified Lang.Crucible.LLVM.MemModel as Mem+import qualified Lang.Crucible.LLVM.MemModel.Generic as Mem.G+import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial+import qualified What4.Expr.Builder as WEB+import qualified What4.Interface as WI+import qualified What4.Protocol.Online as WPO+import qualified What4.SatResult as WS++-- | Store a null-terminated string to memory.+storeNullTerminatedString ::+  forall sym bak w.+  ( LCB.IsSymBackend sym bak+  , WI.IsExpr (WI.SymExpr sym)+  , LCLM.HasPtrWidth w+  , LCLM.HasLLVMAnn sym+  , ?memOpts :: LCLM.MemOptions+  ) =>+  bak ->+  LCLM.MemImpl sym ->+  -- | Pointer to write string to+  LCLM.LLVMPtr sym w ->+  -- | The bytes of the string to write (null terminator included)+  Vec.Vector (WI.SymBV sym 8) ->+  IO (LCLM.MemImpl sym)+storeNullTerminatedString bak mem ptr bytesBvs = do+  let sym = LCB.backendGetSym bak+  zeroNat <- WI.natLit sym 0+  let bytes = Vec.map (Mem.LLVMValInt zeroNat) bytesBvs+  let val = Mem.LLVMValArray (Mem.bitvectorType 1) bytes+  let storTy = Mem.llvmValStorableType @sym val+  Mem.storeRaw bak mem ptr storTy CLD.noAlignment val++-- | Store a string to memory, adding a null terminator at the end.+storeString ::+  forall sym bak w.+  ( LCB.IsSymBackend sym bak+  , WI.IsExpr (WI.SymExpr sym)+  , LCLM.HasPtrWidth w+  , LCLM.HasLLVMAnn sym+  , ?memOpts :: LCLM.MemOptions+  ) =>+  bak ->+  LCLM.MemImpl sym ->+  -- | Pointer to write string to+  LCLM.LLVMPtr sym w ->+  -- | The bytes of the string to write (null terminator not included)+  Vec.Vector (WI.SymBV sym 8) ->+  IO (LCLM.MemImpl sym)+storeString bak mem ptr bytesBvs = do+  let sym = LCB.backendGetSym bak+  zeroByte <- WI.bvZero sym (DPN.knownNat @8)+  let nullTerminatedBytes = Vec.snoc bytesBvs zeroByte+  storeNullTerminatedString bak mem ptr nullTerminatedBytes++---------------------------------------------------------------------+-- * Loading strings++-- | Load a null-terminated string (with a concrete null terminator) from memory.+--+-- The string must contain a concrete null terminator. If a maximum number of+-- characters is provided, no more than that number of characters will be read.+-- In either case, 'loadConcretelyNullTerminatedString' will stop reading if it+-- encounters a (concretely) null terminator.+--+-- Note that the loaded string may actually be smaller than the returned list if+-- any of the symbolic bytes are equal to 0.+loadConcretelyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO [WI.SymBV sym 8]+loadConcretelyNullTerminatedString bak mem ptr limit =+  let loader = llvmByteLoader mem in+  case limit of+    Nothing -> loadBytes bak mem id ptr loader concretelyNullTerminatedString+    Just l ->+      let byteChecker = withMaxChars l (\f -> pure (f [])) concretelyNullTerminatedString in+      loadBytes bak mem (id, 0) ptr loader byteChecker++-- | Load a null-terminated string from memory.+--+-- Consults an SMT solver to check if any of the loaded bytes are known+-- to be null (0). If a maximum number of characters is provided, no+-- more than that number of charcters will be read. In either case,+-- 'loadProvablyNullTerminatedString' will stop reading if it encounters a null+-- terminator.+--+-- Note that the loaded string may actually be smaller than the returned list if+-- any of the symbolic bytes are equal to 0.+loadProvablyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , sym ~ WEB.ExprBuilder scope st fs+  , bak ~ LCBO.OnlineBackend solver scope st fs+  , WPO.OnlineSolver solver+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO [WI.SymBV sym 8]+loadProvablyNullTerminatedString bak mem ptr limit =+  let loader = llvmByteLoader mem in+  case limit of+    Nothing -> loadBytes bak mem id ptr loader provablyNullTerminatedString+    Just l ->+      let byteChecker = withMaxChars l (\f -> pure (f [])) provablyNullTerminatedString in+      loadBytes bak mem (id, 0) ptr loader byteChecker++---------------------------------------------------------------------+-- * String length++-- | Implementation of libc @strnlen@.+strnlen ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Pointer to null-terminated string+  Mem.LLVMPtr sym wptr ->+  -- | Size+  --+  -- If this is not concrete, this will generate an assertion failure.+  WI.SymBV sym wptr ->+  IO (WI.SymBV sym wptr)+strnlen bak mem ptr bound = do+  case BV.asUnsigned <$> WI.asBV bound of+    Nothing ->+      let err = LCS.AssertFailureSimError "`strnlen` called with symbolic max length" "" in+      LCB.addFailedAssertion bak err+    Just b ->+      let bound' = Just (fromIntegral b) in+      strlenConcretelyNullTerminatedString bak mem ptr bound'+ +-- | @strlen@ of a concrete string.+--+-- If any symbolic bytes are encountered, an assertion failure will be+-- generated. If a maximum number of characters is provided, no more than that+-- number of characters will be read. In either case, 'strlenConcreteString'+-- will stop reading if it encounters a null terminator.+strlenConcreteString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO Int+strlenConcreteString bak mem ptr limit = do+  let loader = llvmByteLoader mem+  case limit of+    Nothing -> loadBytes bak mem 0 ptr loader fullyConcreteNullTerminatedStringLength+    Just 0 -> pure 0+    Just l -> do+      let byteChecker = withMaxChars l pure fullyConcreteNullTerminatedStringLength+      loadBytes bak mem (0, 0) ptr loader byteChecker+ +-- | @strlen@ of a null-terminated string (with a concrete null terminator).+--+-- The string must contain a concrete null terminator. If a maximum number of+-- characters is provided, no more than that number of characters will be read.+-- In either case, 'strlenConcretelyNullTerminatedString' will stop reading if+-- it encounters a (concretely) null terminator.+--+-- This has the same behavior as 'Lang.Crucible.LLVM.MemModel.strLen', except+-- that it supports a maximum length.+strlenConcretelyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO (WI.SymBV sym wptr)+strlenConcretelyNullTerminatedString bak mem ptr limit = do+  let loader = llvmByteLoader mem+  let sym = LCB.backendGetSym bak+  z <- WI.bvZero sym ?ptrWidth+  flip State.evalStateT (WI.truePred sym) $+    case limit of+      Nothing -> loadBytes bak mem z ptr loader concretelyNullTerminatedStringLength+      Just 0 -> liftIO (WI.bvZero (LCB.backendGetSym bak) ?ptrWidth)+      Just l -> do+        let byteChecker = withMaxChars l pure concretelyNullTerminatedStringLength+        loadBytes bak mem (z, 0) ptr loader byteChecker++-- | @strlen@ of a provably null-terminated string.+--+-- Consults an SMT solver to check if any of the loaded bytes are known+-- to be null (0). If a maximum number of characters is provided, no+-- more than that number of charcters will be read. In either case,+-- 'strlenProvablyNullTerminatedString' will stop reading if it encounters a+-- (provably) null terminator.+strlenProvablyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , sym ~ WEB.ExprBuilder scope st fs+  , bak ~ LCBO.OnlineBackend solver scope st fs+  , WPO.OnlineSolver solver+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO (WI.SymBV sym wptr)+strlenProvablyNullTerminatedString bak mem ptr limit = do+  let loader = llvmByteLoader mem+  let sym = LCB.backendGetSym bak+  z <- WI.bvZero sym ?ptrWidth+  flip State.evalStateT (WI.truePred sym) $+    case limit of+      Nothing -> loadBytes bak mem z ptr loader provablyNullTerminatedStringLength+      Just 0 -> liftIO (WI.bvZero (LCB.backendGetSym bak) ?ptrWidth)+      Just l -> do+        let byteChecker = withMaxChars l pure provablyNullTerminatedStringLength+        loadBytes bak mem (z, 0) ptr loader byteChecker++---------------------------------------------------------------------+-- * String copying++-- | Helper, not exported+strcpyAssertDisjoint ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Loaded bytes+  Vec.Vector (WI.SymBV sym 8) ->+  -- | Destination pointer+  Mem.LLVMPtr sym wptr ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  IO ()+strcpyAssertDisjoint bak mem bytes dst src = do+  let sym = LCB.backendGetSym bak+  let len = fromIntegral (Vec.length bytes)+  sz <- WI.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth len)+  let heap = mem ^. to Mem.memImplHeap+  let memOp =+        MemErr.MemCopyOp (Just "strcpy dst", dst) (Just "strcpy src", src) sz heap+  Mem.assertDisjointRegions bak memOp ?ptrWidth dst sz src sz++-- | @strcpy@ of a concrete string.+--+-- Uses 'Mem.loadString' to load the string, see that function for details.+--+-- Asserts that the regions are disjoint.+copyConcreteString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Destination pointer+  Mem.LLVMPtr sym wptr ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  IO (Mem.MemImpl sym)+copyConcreteString bak mem dst src = do+  bytes <- Mem.loadString bak mem src Nothing+  let sym = LCB.backendGetSym bak+  symBytes <- mapM (WI.bvLit sym WI.knownRepr . BV.word8) bytes+  let bytesVec = Vec.fromList symBytes+  strcpyAssertDisjoint bak mem bytesVec dst src+  storeString bak mem dst (Vec.fromList symBytes)++-- | @strcpy@ of a concretely null-terminated string.+--+-- Uses 'loadConcretelyNullTerminatedString' to load the string, see that+-- function for details.+--+-- Asserts that the regions are disjoint.+copyConcretelyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Destination pointer+  Mem.LLVMPtr sym wptr ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO (Mem.MemImpl sym)+copyConcretelyNullTerminatedString bak mem dst src bounds = do+  bytes <- loadConcretelyNullTerminatedString bak mem src bounds+  let bytesVec = Vec.fromList bytes+  strcpyAssertDisjoint bak mem bytesVec dst src+  storeString bak mem dst bytesVec++-- | @strcpy@ of a concrete string.+--+-- Uses 'loadProvablyNullTerminatedString' to load the string, see that+-- function for details.+--+-- Asserts that the regions are disjoint.+copyProvablyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , sym ~ WEB.ExprBuilder scope st fs+  , bak ~ LCBO.OnlineBackend solver scope st fs+  , WPO.OnlineSolver solver+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Destination pointer+  Mem.LLVMPtr sym wptr ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  IO (Mem.MemImpl sym)+copyProvablyNullTerminatedString bak mem dst src bounds = do+  bytes <- loadProvablyNullTerminatedString bak mem src bounds+  let bytesVec = Vec.fromList bytes+  strcpyAssertDisjoint bak mem bytesVec dst src+  storeString bak mem dst bytesVec++---------------------------------------------------------------------+-- * String duplication++-- | Helper function: allocate memory and store bytes for string duplication.+--+-- Takes a vector of bytes (NOT including null terminator) and:+-- 1. Allocates memory of the appropriate size (length + 1 for null terminator)+-- 2. Stores the bytes with null terminator to the allocated memory+-- 3. Returns the new pointer and updated memory+dupFromLoadedBytes ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Vec.Vector (WI.SymBV sym 8) ->+  String ->+  CLD.Alignment ->+  IO (Mem.LLVMPtr sym wptr, Mem.MemImpl sym)+dupFromLoadedBytes bak mem bytesVec displayString alignment = do+  let len = fromIntegral (Vec.length bytesVec) + 1  -- +1 for null terminator+  let sym = LCB.backendGetSym bak+  sz <- WI.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth len)+  (dst, mem') <- Mem.doMalloc bak Mem.G.HeapAlloc Mem.G.Mutable displayString mem sz alignment+  mem'' <- storeString bak mem' dst bytesVec+  pure (dst, mem'')++-- | @strdup@ of a concrete string.+--+-- Uses 'Mem.loadString' to load the string, see that function for details.+--+-- Allocates memory and copies the string to it, returning the new pointer.+dupConcreteString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  -- | Display string for allocation+  String ->+  -- | Alignment+  CLD.Alignment ->+  IO (Mem.LLVMPtr sym wptr, Mem.MemImpl sym)+dupConcreteString bak mem src displayString alignment = do+  bytes <- Mem.loadString bak mem src Nothing+  let sym = LCB.backendGetSym bak+  symBytes <- mapM (WI.bvLit sym WI.knownRepr . BV.word8) bytes+  dupFromLoadedBytes bak mem (Vec.fromList symBytes) displayString alignment++-- | @strdup@ of a concretely null-terminated string.+--+-- Uses 'loadConcretelyNullTerminatedString' to load the string, see that+-- function for details.+--+-- Allocates memory and copies the string to it, returning the new pointer.+dupConcretelyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  -- | Display string for allocation+  String ->+  CLD.Alignment ->+  IO (Mem.LLVMPtr sym wptr, Mem.MemImpl sym)+dupConcretelyNullTerminatedString bak mem src bounds displayString alignment = do+  bytes <- loadConcretelyNullTerminatedString bak mem src bounds+  dupFromLoadedBytes bak mem (Vec.fromList bytes) displayString alignment++-- | @strdup@ of a provably null-terminated string.+--+-- Uses 'loadProvablyNullTerminatedString' to load the string, see that+-- function for details.+--+-- Allocates memory and copies the string to it, returning the new pointer.+dupProvablyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , sym ~ WEB.ExprBuilder scope st fs+  , bak ~ LCBO.OnlineBackend solver scope st fs+  , WPO.OnlineSolver solver+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Source pointer+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to read+  Maybe Int ->+  -- | Display string for allocation+  String ->+  CLD.Alignment ->+  IO (Mem.LLVMPtr sym wptr, Mem.MemImpl sym)+dupProvablyNullTerminatedString bak mem src bounds displayString alignment = do+  bytes <- loadProvablyNullTerminatedString bak mem src bounds+  dupFromLoadedBytes bak mem (Vec.fromList bytes) displayString alignment++---------------------------------------------------------------------+-- * String comparison++-- | Compare two concrete strings.+--+-- Uses 'fullyConcreteNullTerminatedStrings' checker. Both strings must be+-- fully concrete (no symbolic bytes).+--+-- Returns:+-- * 0 if the strings are equal+-- * A negative value if the first differing byte in s1 is less than in s2+-- * A positive value if the first differing byte in s1 is greater than in s2+cmpConcreteString ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  IO (WI.SymBV sym 32)+cmpConcreteString bak mem ptr1 ptr2 = do+  let sym = LCB.backendGetSym bak+  zero <- WI.bvZero sym (DPN.knownNat @32)+  loadTwoBytes bak mem zero ptr1 ptr2 (llvmStringsLoader mem) fullyConcreteNullTerminatedStrings++-- | Compare two strings with concrete null terminators.+--+-- Uses 'concretelyNullTerminatedStrings' checker. The strings must have+-- concrete null terminators, but may contain symbolic bytes before the terminator.+--+-- If a maximum length is provided, comparison stops at that length even if+-- no null terminator is encountered.+--+-- Returns:+-- * 0 if the strings are equal+-- * A negative value if the first differing byte in s1 is less than in s2+-- * A positive value if the first differing byte in s1 is greater than in s2+cmpConcretelyNullTerminatedString ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to compare+  Maybe Int ->+  IO (WI.SymBV sym 32)+cmpConcretelyNullTerminatedString bak mem ptr1 ptr2 maxLen = do+  let sym = LCB.backendGetSym bak+  zero <- WI.bvZero sym (DPN.knownNat @32)+  case maxLen of+    Nothing ->+      loadTwoBytes bak mem zero ptr1 ptr2 (llvmStringsLoader mem) concretelyNullTerminatedStrings+    Just 0 ->+      WI.bvZero sym (DPN.knownNat @32)+    Just n ->+      loadTwoBytes bak mem (zero, 0) ptr1 ptr2 (llvmStringsLoader mem) (lengthBoundedStringComparison (fromIntegral n))++-- | Compare two strings with provably null terminators.+--+-- Uses 'provablyNullTerminatedStrings' checker. Consults an SMT solver to+-- check if bytes are provably null terminators.+--+-- If a maximum length is provided, comparison stops at that length even if+-- no null terminator is encountered.+--+-- Returns:+-- * 0 if the strings are equal+-- * A negative value if the first differing byte in s1 is less than in s2+-- * A positive value if the first differing byte in s1 is greater than in s2+cmpProvablyNullTerminatedString ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , sym ~ WEB.ExprBuilder scope st fs+  , bak ~ LCBO.OnlineBackend solver scope st fs+  , WPO.OnlineSolver solver+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  -- | Maximum number of characters to compare+  Maybe Int ->+  IO (WI.SymBV sym 32)+cmpProvablyNullTerminatedString bak mem ptr1 ptr2 maxLen = do+  let sym = LCB.backendGetSym bak+  zero <- WI.bvZero sym (DPN.knownNat @32)+  case maxLen of+    Nothing ->+      loadTwoBytes bak mem zero ptr1 ptr2 (llvmStringsLoader mem) provablyNullTerminatedStrings+    Just 0 ->+      WI.bvZero sym (DPN.knownNat @32)+    Just n ->+      loadTwoBytes bak mem (zero, 0) ptr1 ptr2 (llvmStringsLoader mem) (lengthBoundedProvablyNullTerminatedStringComparison (fromIntegral n))++-- | @strncmp@ - compare two null-terminated strings up to n characters.+--+-- See 'strncmpConcreteLen' for the return value.+--+-- Asserts that the length is concrete (non-symbolic).+strncmp ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  WI.SymBV sym wptr ->+  IO (WI.SymBV sym 32)+strncmp bak mem ptr1 ptr2 len =+  case BV.asUnsigned <$> WI.asBV len of+    Just n -> strncmpConcreteLen bak mem ptr1 ptr2 (fromIntegral n)+    Nothing -> do+      let err = LCS.AssertFailureSimError "`strncmp` called with symbolic length" ""+      LCB.addFailedAssertion bak err++-- | Compare two null-terminated strings up to n characters with a concrete length.+--+-- Returns:+-- * 0 if the strings are equal (up to n characters or null terminator)+-- * A negative value if the first differing byte in s1 is less than in s2+-- * A positive value if the first differing byte in s1 is greater than in s2+--+-- Requires that both strings have concrete null terminators.+strncmpConcreteLen ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  Integer ->+  IO (WI.SymBV sym 32)+strncmpConcreteLen bak mem ptr1 ptr2 n =+  cmpConcretelyNullTerminatedString bak mem ptr1 ptr2 (Just (fromIntegral n))++---------------------------------------------------------------------+-- * Memory comparison++-- | @memcmp@.+--+-- See 'memcmpConcreteLen' for the return value.+--+-- Asserts that the length is concrete (non-symbolic).+memcmp ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  WI.SymBV sym wptr ->+  IO (WI.SymBV sym 32)+memcmp bak mem ptr1 ptr2 len =+  case BV.asUnsigned <$> WI.asBV len of+    Just n -> memcmpConcreteLen bak mem ptr1 ptr2 (fromIntegral n)+    Nothing -> do+      let err = LCS.AssertFailureSimError "`memcmp` called with symbolic length" ""+      LCB.addFailedAssertion bak err++-- | Compare two memory regions byte-by-byte with a concrete length.+--+-- Returns:+-- * 0 if the regions are equal+-- * A negative value if the first differing byte in s1 is less than in s2+-- * A positive value if the first differing byte in s1 is greater than in s2+memcmpConcreteLen ::+  forall sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Partial.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  ) =>+  bak ->+  Mem.MemImpl sym ->+  Mem.LLVMPtr sym wptr ->+  Mem.LLVMPtr sym wptr ->+  Integer ->+  IO (WI.SymBV sym 32)+memcmpConcreteLen bak mem ptr1 ptr2 n+  | n == 0 = do+      let sym = LCB.backendGetSym bak+      WI.bvZero sym (DPN.knownNat @32)+  | otherwise =+      loadTwoBytes bak mem ((), 0) ptr1 ptr2 (llvmBytesLoader mem) (lengthBoundedByteComparison n)++---------------------------------------------------------------------+-- * Low-level string loading primitives++---------------------------------------------------------------------+-- ** 'ByteChecker'++-- | Whether to stop or keep going+--+-- Like Rust's @std::ops::ControlFlow@.+data ControlFlow a b+  = Continue a+  | Break b+  deriving Functor++-- NB: 'first' is used in this module+instance Bifunctor ControlFlow where+  bimap l r =+    \case+      Continue x -> Continue (l x)+      Break x -> Break (r x)++-- | Compute a result from a symbolic byte, and check if the load should+-- continue to the next byte.+--+-- Used to:+--+-- * Check if the byte is concrete ('fullyConcreteNullTerminatedString')+-- * Check if the byte is concretely a null terminator+--   ('concretelyNullTerminatedString')+-- * Check if a byte is known by a solver to be a null terminator ('nullTerminatedString')+-- * Check if we have surpassed a length limit ('withMaxChars')+--+-- Note that it is relatively common for @a@ to be a function @[b] -> [b]@. This+-- is used to build up a snoc-list.+newtype ByteChecker m sym bak a b+  = ByteChecker { runByteChecker :: bak -> a -> Mem.LLVMPtr sym 8 -> m (ControlFlow a b) }++-- Helper, not exported+ptrToBv8 ::+  LCB.IsSymBackend sym bak =>+  bak ->+  Mem.LLVMPtr sym 8 ->+  IO (WI.SymBV sym 8)+ptrToBv8 bak bytePtr = do+  let err = LCS.AssertFailureSimError "Found pointer instead of byte when loading string" ""+  Partial.ptrToBv bak err bytePtr++-- | 'ByteChecker' for adding a maximum character length.+withMaxChars ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  Functor m =>+  -- | Maximum number of bytes to load+  Int ->+  -- | What to do when the maximum is reached+  (a -> m b) ->+  ByteChecker m sym bak a b ->+  ByteChecker m sym bak (a, Int) b+withMaxChars limit done checker =+  ByteChecker $ \bak (acc, i) bytePtr ->+    runByteChecker checker bak acc bytePtr >>=+      \case+        Break r -> pure (Break r)+        Continue r ->+          if i + 1 >= limit+          then Break <$> done r+          else pure (Continue (r, i + 1))++---------------------------------------------------------------------+-- *** For loading strings++-- | 'ByteChecker' for loading concrete strings.+--+-- Currently unused internally, but analogous with+-- 'Lang.Crucible.LLVM.MemModel.loadString'. In fact, it would be good to define+-- that function in terms of this one. However, this is blocked on TODO(#1406).+fullyConcreteNullTerminatedString ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  ByteChecker m sym bak ([Word8] -> [Word8]) [Word8]+fullyConcreteNullTerminatedString =+  ByteChecker $ \bak acc bytePtr -> do+    byte <- liftIO (ptrToBv8 bak bytePtr)+    case BV.asUnsigned <$> WI.asBV byte of+      Just 0 -> pure (Break (acc []))+      Just c -> do+        let c' = toEnum @Word8 (fromInteger c)+        pure (Continue (\l -> acc (c' : l)))+      Nothing -> do+        let msg = "Symbolic value encountered when loading a string"+        liftIO (LCB.addFailedAssertion bak (LCS.Unsupported GHC.callStack msg))++-- | 'ByteChecker' for loading symbolic strings with a concrete null terminator.+--+-- Used in 'loadConcretelyNullTerminatedString'.+concretelyNullTerminatedString ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  ByteChecker m sym bak ([WI.SymBV sym 8] -> [WI.SymBV sym 8]) [WI.SymBV sym 8]+concretelyNullTerminatedString =+  ByteChecker $ \bak acc bytePtr -> do+    byte <- liftIO (ptrToBv8 bak bytePtr)+    if isConcreteNullTerminator byte+    then pure (Break (acc []))+    else  pure (Continue (\l -> acc (byte : l)))+  where+    isConcreteNullTerminator symByte =+      case BV.asUnsigned <$> WI.asBV symByte of+        Just 0 -> True+        _ -> False++-- | 'ByteChecker' for loading symbolic strings with a provably-null terminator.+--+-- Used in 'loadSymbolicString'.+provablyNullTerminatedString ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  sym ~ WEB.ExprBuilder scope st fs =>+  bak ~ LCBO.OnlineBackend solver scope st fs =>+  WPO.OnlineSolver solver =>+  ByteChecker m sym bak ([WI.SymBV sym 8] -> [WI.SymBV sym 8]) [WI.SymBV sym 8]+provablyNullTerminatedString =+  ByteChecker $ \bak acc bytePtr -> liftIO $ do+    byte <- ptrToBv8 bak bytePtr+    let sym = LCB.backendGetSym bak+    isNullTerm <- isProvablyNullTerminator bak sym byte+    if isNullTerm+    then pure (Break (acc []))+    else  pure (Continue (\l -> acc (byte : l)))++-- Helper, not exported+isProvablyNullTerminator ::+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  sym ~ WEB.ExprBuilder scope st fs =>+  bak ~ LCBO.OnlineBackend solver scope st fs =>+  WPO.OnlineSolver solver =>+  bak ->+  sym ->+  WI.SymBV sym 8 ->+  IO Bool+isProvablyNullTerminator bak sym symByte =+  case BV.asUnsigned <$> WI.asBV symByte of+    Just 0 -> pure True+    Just _ -> pure False+    _ ->+      LCBO.withSolverProcess bak (pure False) $ \proc -> do+        z <- WI.bvZero sym (WI.knownNat @8)+        p <- WI.notPred sym =<< WI.bvEq sym z symByte+        WPO.checkSatisfiable proc "isProvablyNullTerminator" p <&>+          \case+            WS.Unsat () -> True+            WS.Sat () -> False+            WS.Unknown -> False++---------------------------------------------------------------------+-- *** For string length++-- | 'ByteChecker' for @strlen@ of concrete strings.+fullyConcreteNullTerminatedStringLength ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  ByteChecker m sym bak Int Int+fullyConcreteNullTerminatedStringLength =+  ByteChecker $ \bak acc bytePtr -> do+    byte <- liftIO (ptrToBv8 bak bytePtr)+    case BV.asUnsigned <$> WI.asBV byte of+      Just 0 -> pure (Break acc)+      Just _ -> pure (Continue $! acc + 1)+      Nothing -> do+        let msg = "Symbolic value encountered when loading a string"+        liftIO (LCB.addFailedAssertion bak (LCS.Unsupported GHC.callStack msg))++-- Helper, not exported+symStringLength ::+  MonadIO m =>+  State.MonadState (WI.Pred sym) m =>+  GHC.HasCallStack =>+  Mem.HasPtrWidth wptr =>+  LCB.IsSymBackend sym bak =>+  -- | How to check if a predicate is false+  (bak -> WI.Pred sym -> m Bool) ->+  ByteChecker m sym bak (WI.SymBV sym wptr) (WI.SymBV sym wptr)+symStringLength predIsFalse =+  ByteChecker $ \bak len bytePtr -> do+    byte <- liftIO (ptrToBv8 bak bytePtr)+    keepGoing <- State.get+    let sym = LCB.backendGetSym bak+    byteWasNonNull <- liftIO (WI.bvIsNonzero sym byte)+    keepGoing' <- liftIO (WI.andPred sym keepGoing byteWasNonNull)+    stopHere <- predIsFalse bak keepGoing'+    if stopHere+    then pure (Break len)+    else do+      State.put keepGoing'+      lenPlusOne <- liftIO (WI.bvAdd sym len =<< WI.bvOne sym ?ptrWidth)+      Continue <$> liftIO (WI.bvIte sym keepGoing' lenPlusOne len)++-- | 'ByteChecker' for @strlen@ of strings with a concrete null terminator.+concretelyNullTerminatedStringLength ::+  MonadIO m =>+  State.MonadState (WI.Pred sym) m =>+  GHC.HasCallStack =>+  Mem.HasPtrWidth wptr =>+  LCB.IsSymBackend sym bak =>+  ByteChecker m sym bak (WI.SymBV sym wptr) (WI.SymBV sym wptr)+concretelyNullTerminatedStringLength =+  symStringLength (\_bak p -> pure (WI.asConstantPred p == Just False))++-- | 'ByteChecker' for @strlen@ for strings with a provably-null terminator.+provablyNullTerminatedStringLength ::+  MonadIO m =>+  State.MonadState (WI.Pred sym) m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  Mem.HasPtrWidth wptr =>+  sym ~ WEB.ExprBuilder scope st fs =>+  bak ~ LCBO.OnlineBackend solver scope st fs =>+  WPO.OnlineSolver solver =>+  ByteChecker m sym bak (WI.SymBV sym wptr) (WI.SymBV sym wptr)+provablyNullTerminatedStringLength =+  symStringLength $ \bak p ->+    case WI.asConstantPred p of+      Just b -> pure b+      _ ->+        liftIO $ LCBO.withSolverProcess bak (pure False) $ \proc -> do+          WPO.checkSatisfiable proc "provablyNullTerminatedStringLength" p <&>+            \case+              WS.Unsat () -> True+              WS.Sat () -> False+              WS.Unknown -> False++---------------------------------------------------------------------+-- ** 'ByteLoader'++-- | Load a byte from memory.+--+-- The only 'ByteLoader' defined here is 'llvmByteLoader', but Macaw users will+-- most often want one based on @doReadMemModel@.+newtype ByteLoader m sym bak wptr+  = ByteLoader { runByteLoader :: bak -> Mem.LLVMPtr sym wptr -> m (Mem.LLVMPtr sym 8) }++-- | A 'ByteLoader' for LLVM memory based on 'Mem.doLoad'.+llvmByteLoader ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , MonadIO m+  ) =>+  Mem.MemImpl sym ->+  ByteLoader m sym bak wptr+llvmByteLoader mem =+  ByteLoader $ \bak ptr -> do+    let i1 = Mem.bitvectorType 1+    let p8 = Mem.LLVMPointerRepr (DPN.knownNat @8)+    liftIO (Mem.doLoad bak mem ptr i1 p8 CLD.noAlignment)++---------------------------------------------------------------------+-- * 'loadBytes'++-- | Load a sequence of bytes, one at a time.+--+-- Used to implement 'loadConcretelyNullTerminatedString' and+-- 'loadSymbolicString'. Highly customizable via 'ByteLoader' and 'ByteChecker'.+loadBytes ::+  forall m a b sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , MonadIO m+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Initial accumulator+  a ->+  -- | Pointer to load from+  Mem.LLVMPtr sym wptr ->+  -- | How to load a byte from memory+  ByteLoader m sym bak wptr ->+  -- | How to check if we should continue loading the next byte+  ByteChecker m sym bak a b ->+  m b+loadBytes bak mem = go+ where+  sym = LCB.backendGetSym bak+  go ::+    a ->+    Mem.LLVMPtr sym wptr ->+    ByteLoader m sym bak wptr ->+    ByteChecker m sym bak a b ->+    m b+  go acc ptr loader checker = do+    byte <- runByteLoader loader bak ptr+    runByteChecker checker bak acc byte >>=+      \case+        Break result -> pure result+        Continue acc' -> do+          -- It is important that safety assertions for later loads can use+          -- the assumption that earlier bytes were nonzero, see #1463 or+          -- `crucible-llvm-cli/test-data/T1463-read-bytes.cbl` for details.+          prevByteWasNonNull <-+            liftIO (WI.notPred sym =<< Mem.ptrIsNull sym (WI.knownNat @8) byte)+          loc <- liftIO (WI.getCurrentProgramLoc sym)+          let assump = LCB.BranchCondition loc Nothing prevByteWasNonNull+          liftIO (LCB.addAssumption bak assump)++          ptr' <- liftIO (Mem.doPtrAddOffset bak mem ptr =<< WI.bvOne sym Mem.PtrWidth)+          go acc' ptr' loader checker++---------------------------------------------------------------------+-- * Loading and checking two byte streams++-- ** 'BytesLoader'++-- | Load a byte from each of two memory locations.+--+-- The loader can optionally add assumptions after loading bytes when iteration+-- continues. This is used for null-terminated string operations where we need+-- to assume loaded bytes are non-null.+--+-- Like 'ByteLoader', but for two bytes (usually from different strings) at+-- once.+data BytesLoader m sym bak wptr+  = BytesLoader+      { runBytesLoader :: bak -> Mem.LLVMPtr sym wptr -> Mem.LLVMPtr sym wptr -> m (Mem.LLVMPtr sym 8, Mem.LLVMPtr sym 8)+      -- | Called when the 'BytesChecker' returns 'Continue', allowing the+      -- loader to add assumptions about the loaded bytes (e.g., that they are+      -- non-null).+      , onContinue :: bak -> Mem.LLVMPtr sym 8 -> Mem.LLVMPtr sym 8 -> m ()+      }++-- | A 'BytesLoader' for LLVM memory based on 'Mem.doLoad'.+--+-- This version does not add any assumptions about loaded bytes.+-- Use this for length-bounded operations like @memcmp@ that need to handle+-- null bytes in the middle of the data.+llvmBytesLoader ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , MonadIO m+  ) =>+  Mem.MemImpl sym ->+  BytesLoader m sym bak wptr+llvmBytesLoader mem =+  BytesLoader+    { runBytesLoader = \bak ptr1 ptr2 -> do+        let i1 = Mem.bitvectorType 1+        let p8 = Mem.LLVMPointerRepr (DPN.knownNat @8)+        byte1 <- liftIO (Mem.doLoad bak mem ptr1 i1 p8 CLD.noAlignment)+        byte2 <- liftIO (Mem.doLoad bak mem ptr2 i1 p8 CLD.noAlignment)+        pure (byte1, byte2)+    , onContinue = \_ _ _ -> pure ()+    }++-- | A 'BytesLoader' for LLVM memory that adds non-null assumptions.+--+-- This version adds assumptions that loaded bytes are non-null when iteration+-- continues. Use this for null-terminated string operations like @strcmp@.+llvmStringsLoader ::+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , MonadIO m+  ) =>+  Mem.MemImpl sym ->+  BytesLoader m sym bak wptr+llvmStringsLoader mem =+  BytesLoader+    { runBytesLoader = \bak ptr1 ptr2 -> do+        let i1 = Mem.bitvectorType 1+        let p8 = Mem.LLVMPointerRepr (DPN.knownNat @8)+        byte1 <- liftIO (Mem.doLoad bak mem ptr1 i1 p8 CLD.noAlignment)+        byte2 <- liftIO (Mem.doLoad bak mem ptr2 i1 p8 CLD.noAlignment)+        pure (byte1, byte2)+    , onContinue = \bak byte1 byte2 -> liftIO $ do+        let sym = LCB.backendGetSym bak+        -- Add assumptions that both bytes were nonzero+        prevByte1WasNonNull <- WI.notPred sym =<< Mem.ptrIsNull sym (WI.knownNat @8) byte1+        prevByte2WasNonNull <- WI.notPred sym =<< Mem.ptrIsNull sym (WI.knownNat @8) byte2+        loc <- WI.getCurrentProgramLoc sym+        let assump1 = LCB.BranchCondition loc Nothing prevByte1WasNonNull+        let assump2 = LCB.BranchCondition loc Nothing prevByte2WasNonNull+        LCB.addAssumption bak assump1+        LCB.addAssumption bak assump2+    }++---------------------------------------------------------------------+-- ** 'BytesChecker'++-- | Compute a result from two symbolic bytes, and check if loading should+-- continue to the next pair of bytes.+--+-- Used to compare two byte streams simultaneously, e.g., for 'strcmp'.+--+-- Like 'ByteChecker', but for two bytes (usually from different strings) at+-- once.+newtype BytesChecker m sym bak a b+  = BytesChecker+      { runBytesChecker :: bak -> a -> Mem.LLVMPtr sym 8 -> Mem.LLVMPtr sym 8 -> m (ControlFlow a b) }++-- | 'BytesChecker' for adding a maximum byte length.+withMaxBytes ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  Functor m =>+  -- | Maximum number of bytes to compare+  Integer ->+  -- | What to do when the maximum is reached+  (bak -> a -> m b) ->+  BytesChecker m sym bak a b ->+  BytesChecker m sym bak (a, Integer) b+withMaxBytes limit done checker =+  BytesChecker $ \bak (acc, i) byte1Ptr byte2Ptr ->+    runBytesChecker checker bak acc byte1Ptr byte2Ptr >>=+      \case+        Break r -> pure (Break r)+        Continue r ->+          if i + 1 >= limit+          then Break <$> done bak r+          else pure (Continue (r, i + 1))++-- ** 'loadTwoBytes'++-- | Load sequences of bytes from two pointers simultaneously.+--+-- Used to implement 'strcmp'. Similar to 'loadBytes' but operates on two byte streams.+loadTwoBytes ::+  forall m a b sym bak wptr.+  ( LCB.IsSymBackend sym bak+  , Mem.HasPtrWidth wptr+  , Mem.HasLLVMAnn sym+  , ?memOpts :: Mem.MemOptions+  , GHC.HasCallStack+  , MonadIO m+  ) =>+  bak ->+  Mem.MemImpl sym ->+  -- | Initial accumulator+  a ->+  -- | First pointer to load from+  Mem.LLVMPtr sym wptr ->+  -- | Second pointer to load from+  Mem.LLVMPtr sym wptr ->+  -- | How to load a byte from each memory location+  BytesLoader m sym bak wptr ->+  -- | How to check if we should continue loading the next bytes+  BytesChecker m sym bak a b ->+  m b+loadTwoBytes bak mem = go+ where+  sym = LCB.backendGetSym bak+  go ::+    a ->+    Mem.LLVMPtr sym wptr ->+    Mem.LLVMPtr sym wptr ->+    BytesLoader m sym bak wptr ->+    BytesChecker m sym bak a b ->+    m b+  go acc ptr1 ptr2 loader checker = do+    (byte1, byte2) <- runBytesLoader loader bak ptr1 ptr2+    runBytesChecker checker bak acc byte1 byte2 >>=+      \case+        Break result -> pure result+        Continue acc' -> do+          -- Let the loader add any assumptions it needs (e.g., non-null for strcmp)+          onContinue loader bak byte1 byte2++          ptr1' <- liftIO (Mem.doPtrAddOffset bak mem ptr1 =<< WI.bvOne sym Mem.PtrWidth)+          ptr2' <- liftIO (Mem.doPtrAddOffset bak mem ptr2 =<< WI.bvOne sym Mem.PtrWidth)+          go acc' ptr1' ptr2' loader checker++---------------------------------------------------------------------+-- ** BytesCheckers for string comparison++-- Helper, not exported+-- Common logic for comparing two bytes after null-terminator checking.+-- Returns Nothing if bytes are equal (should continue), or Just result if different.+compareBytesForStrings ::+  MonadIO m =>+  LCB.IsSymBackend sym bak =>+  bak ->+  WI.SymBV sym 8 ->+  WI.SymBV sym 8 ->+  m (Maybe (WI.SymBV sym 32))+compareBytesForStrings bak byte1 byte2 = do+  let sym = LCB.backendGetSym bak+  let i32 = DPN.knownNat @32+  eq <- liftIO (WI.bvEq sym byte1 byte2)+  case WI.asConstantPred eq of+    Just False -> do+      lt <- liftIO (WI.bvUlt sym byte1 byte2)+      negOne <- liftIO (WI.bvLit sym i32 (BV.mkBV i32 -1))+      one <- liftIO (WI.bvOne sym i32)+      result <- liftIO (WI.bvIte sym lt negOne one)+      pure (Just result)+    _ -> pure Nothing++-- Helper, not exported+-- Common logic for handling null terminator cases in string comparison.+-- Returns Nothing if bytes are equal (should continue), or Just result if different or at null terminator.+handleNullTerminators ::+  MonadIO m =>+  LCB.IsSymBackend sym bak =>+  bak ->+  WI.SymBV sym 32 ->+  Bool ->+  Bool ->+  WI.SymBV sym 8 ->+  WI.SymBV sym 8 ->+  m (Maybe (WI.SymBV sym 32))+handleNullTerminators bak bothNullResult isNull1 isNull2 byte1 byte2 = do+  let sym = LCB.backendGetSym bak+  let i32 = DPN.knownNat @32+  case (isNull1, isNull2) of+    (True, True) -> pure (Just bothNullResult)+    (True, False) -> do+      negOne <- liftIO (WI.bvLit sym i32 (BV.mkBV i32 -1))+      pure (Just negOne)+    (False, True) -> do+      one <- liftIO (WI.bvOne sym i32)+      pure (Just one)+    (False, False) -> compareBytesForStrings bak byte1 byte2++-- | 'BytesChecker' for comparing concrete strings.+--+-- Stops when either string has a concrete null terminator.+fullyConcreteNullTerminatedStrings ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  BytesChecker m sym bak (WI.SymBV sym 32) (WI.SymBV sym 32)+fullyConcreteNullTerminatedStrings =+  BytesChecker $ \bak acc byte1Ptr byte2Ptr -> do+    byte1 <- liftIO (ptrToBv8 bak byte1Ptr)+    byte2 <- liftIO (ptrToBv8 bak byte2Ptr)+    let sym = LCB.backendGetSym bak+    let i32 = DPN.knownNat @32++    case (BV.asUnsigned <$> WI.asBV byte1, BV.asUnsigned <$> WI.asBV byte2) of+      (Just 0, Just 0) -> pure (Break acc)+      (Just 0, Just _) -> do+        negOne <- liftIO (WI.bvLit sym i32 (BV.mkBV i32 -1))+        pure (Break negOne)+      (Just _, Just 0) -> do+        one <- liftIO (WI.bvOne sym i32)+        pure (Break one)+      (Just c1, Just c2) | c1 == c2 -> pure (Continue acc)+      (Just c1, Just c2) -> do+        if c1 < c2+          then do+            negOne <- liftIO (WI.bvLit sym i32 (BV.mkBV i32 -1))+            pure (Break negOne)+          else do+            one <- liftIO (WI.bvOne sym i32)+            pure (Break one)+      _ -> do+        let msg = "Symbolic value encountered when comparing strings"+        liftIO (LCB.addFailedAssertion bak (LCS.Unsupported GHC.callStack msg))++-- | 'BytesChecker' for comparing strings with concrete null terminators.+--+-- Stops when either string has a concrete null terminator.+concretelyNullTerminatedStrings ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  BytesChecker m sym bak (WI.SymBV sym 32) (WI.SymBV sym 32)+concretelyNullTerminatedStrings =+  BytesChecker $ \bak acc byte1Ptr byte2Ptr -> do+    byte1 <- liftIO (ptrToBv8 bak byte1Ptr)+    byte2 <- liftIO (ptrToBv8 bak byte2Ptr)++    let isNull1 = (BV.asUnsigned <$> WI.asBV byte1) == Just 0+    let isNull2 = (BV.asUnsigned <$> WI.asBV byte2) == Just 0++    handleNullTerminators bak acc isNull1 isNull2 byte1 byte2 >>= \case+      Just result -> pure (Break result)+      Nothing -> pure (Continue acc)++-- | 'BytesChecker' for comparing strings with provably null terminators.+--+-- Stops when either string is provably null-terminated.+provablyNullTerminatedStrings ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  sym ~ WEB.ExprBuilder scope st fs =>+  bak ~ LCBO.OnlineBackend solver scope st fs =>+  WPO.OnlineSolver solver =>+  BytesChecker m sym bak (WI.SymBV sym 32) (WI.SymBV sym 32)+provablyNullTerminatedStrings =+  BytesChecker $ \bak acc byte1Ptr byte2Ptr -> liftIO $ do+    byte1 <- ptrToBv8 bak byte1Ptr+    byte2 <- ptrToBv8 bak byte2Ptr+    let sym = LCB.backendGetSym bak++    isNull1 <- isProvablyNullTerminator bak sym byte1+    isNull2 <- isProvablyNullTerminator bak sym byte2++    handleNullTerminators bak acc isNull1 isNull2 byte1 byte2 >>= \case+      Just result -> pure (Break result)+      Nothing -> pure (Continue acc)++-- | 'BytesChecker' for comparing strings with concrete null terminators+-- up to a maximum length.+--+-- Combines null-terminator checking (like strcmp) with length bounding+-- (like memcmp). Used for strncmp.+--+-- The accumulator is a pair of the comparison result so far and the current index.+lengthBoundedStringComparison ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  Integer ->+  BytesChecker m sym bak (WI.SymBV sym 32, Integer) (WI.SymBV sym 32)+lengthBoundedStringComparison maxLen =+  let onMaxBytes _bak zero = pure zero+  in withMaxBytes maxLen onMaxBytes concretelyNullTerminatedStrings++-- | 'BytesChecker' for comparing strings with provably null terminators+-- up to a maximum length.+--+-- Combines provably null-terminator checking with length bounding.+--+-- The accumulator is a pair of the comparison result so far and the current index.+lengthBoundedProvablyNullTerminatedStringComparison ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  sym ~ WEB.ExprBuilder scope st fs =>+  bak ~ LCBO.OnlineBackend solver scope st fs =>+  WPO.OnlineSolver solver =>+  Integer ->+  BytesChecker m sym bak (WI.SymBV sym 32, Integer) (WI.SymBV sym 32)+lengthBoundedProvablyNullTerminatedStringComparison maxLen =+  let onMaxBytes _bak zero = pure zero+  in withMaxBytes maxLen onMaxBytes provablyNullTerminatedStrings++---------------------------------------------------------------------+-- ** BytesCheckers for length-bounded comparison++-- | 'BytesChecker' for comparing two bytes without length bounds.+--+-- Stops when bytes differ, otherwise continues indefinitely.+simpleByteComparison ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  BytesChecker m sym bak () (WI.SymBV sym 32)+simpleByteComparison =+  BytesChecker $ \bak () byte1Ptr byte2Ptr -> do+    byte1 <- liftIO (ptrToBv8 bak byte1Ptr)+    byte2 <- liftIO (ptrToBv8 bak byte2Ptr)+    compareBytesForStrings bak byte1 byte2 >>= \case+      Just result -> pure (Break result)+      Nothing -> pure (Continue ())++-- | 'BytesChecker' for comparing memory regions with a concrete length bound.+--+-- The accumulator is a pair of unit and the current index. Stops when the index reaches the+-- maximum length, or when bytes differ.+--+-- Returns:+-- * 0 if all bytes up to the length are equal+-- * A negative value if the first differing byte in the first region is less+-- * A positive value if the first differing byte in the first region is greater+lengthBoundedByteComparison ::+  MonadIO m =>+  GHC.HasCallStack =>+  LCB.IsSymBackend sym bak =>+  -- | Maximum length+  Integer ->+  BytesChecker m sym bak ((), Integer) (WI.SymBV sym 32)+lengthBoundedByteComparison maxLen =+  let onMaxBytes bak () = liftIO (WI.bvZero (LCB.backendGetSym bak) (DPN.knownNat @32))+  in withMaxBytes maxLen onMaxBytes simpleByteComparison
src/Lang/Crucible/LLVM/MemModel/Type.hs view
@@ -35,12 +35,12 @@   , 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 Lens.Micro (Lens, lens, (^.)) import Prettyprinter  import Lang.Crucible.LLVM.Bytes
src/Lang/Crucible/LLVM/MemModel/Value.hs view
@@ -39,15 +39,17 @@   , 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           Lens.Micro ((^.), _2, over)+import           Lens.Micro.Extras (view)+ import           Data.List (intersperse)+import           Data.Maybe (fromMaybe, mapMaybe) import           Numeric.Natural import           Prettyprinter @@ -107,8 +109,11 @@   -- | The @undef@ value exists at all storage types.   LLVMValUndef :: StorageType -> LLVMVal sym +  -- | The @poison@ value exists at all storage types.+  LLVMValPoison :: StorageType -> LLVMVal sym -llvmValStorableType :: IsExprBuilder sym => LLVMVal sym -> StorageType++llvmValStorableType :: IsExpr (SymExpr sym) => LLVMVal sym -> StorageType llvmValStorableType v =   case v of     LLVMValInt _ bv -> bitvectorType (bitsToBytes (natValue (bvWidth bv)))@@ -120,6 +125,7 @@     LLVMValString bs -> arrayType (fromIntegral (BS.length bs)) (bitvectorType (Bytes 1))     LLVMValZero tp -> tp     LLVMValUndef tp -> tp+    LLVMValPoison tp -> tp  -- | Create a fresh 'LLVMVal' of the given type. freshLLVMVal :: IsSymInterface sym =>@@ -145,6 +151,7 @@   case t of     LLVMValZero _tp -> pretty "0"     LLVMValUndef tp -> pretty "<undef : " <> viaShow tp <> pretty ">"+    LLVMValPoison tp -> pretty "<poison : " <> viaShow tp <> pretty ">"     LLVMValString bs -> viaShow bs     LLVMValInt base off -> ppPtr @sym (LLVMPointer base off)     LLVMValFloat _ v -> printSymExpr v@@ -191,6 +198,7 @@     \case       (LLVMValZero tp) -> pure $ angles (typed "zero" tp)       (LLVMValUndef tp) -> pure $ angles (typed "undef" tp)+      (LLVMValPoison tp) -> pure $ angles (typed "poison" tp)       (LLVMValString bs) -> pure $ viaShow bs       (LLVMValInt blk w) -> fromMaybe otherDoc <$> ppInt blk w         where@@ -257,6 +265,7 @@ instance IsExpr (SymExpr sym) => Show (LLVMVal sym) where   show (LLVMValZero _tp) = "0"   show (LLVMValUndef tp) = "<undef : " ++ show tp ++ ">"+  show (LLVMValPoison tp) = "<poison : " ++ show tp ++ ">"   show (LLVMValString  _) = "<string>"   show (LLVMValInt blk w)     | Just 0 <- asNat blk = "<int" ++ show (bvWidth w) ++ ">"@@ -333,9 +342,9 @@ -- -- 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'.+-- early on a constantly false answer or 'LLVMValUndef' or 'LLVMValPoison'. ----- Returns 'Nothing' for 'LLVMValUndef'.+-- Returns 'Nothing' for 'LLVMValUndef' or 'LLVMValPoison'. isZero :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym)        => sym -> LLVMVal sym -> IO (Maybe (Pred sym)) isZero sym v =@@ -345,9 +354,9 @@     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)+    LLVMValPoison _   -> pure Nothing+    LLVMValInt {}     -> compareToZeroExpansion+    LLVMValFloat {}   -> compareToZeroExpansion   where     areZero :: Traversable t => t (LLVMVal sym) -> IO (Maybe (t (Pred sym)))     areZero = fmap sequence . traverse (isZero sym)@@ -356,9 +365,15 @@       -- This could probably be simplified with a well-placed =<<...       join $ fmap commuteMaybe $ fmap (fmap (allOf sym . toList)) $ areZero vs +    -- Check if a value is equal to itself after zero-expansion. This is+    -- suitable for checking atomic types (e.g., integers and floats).+    compareToZeroExpansion =+      testEqual sym v =<< zeroExpandLLVMVal sym (llvmValStorableType v)+ -- | A predicate denoting the equality of two LLVMVals. ----- Returns 'Nothing' in the event that one of the values contains 'LLVMValUndef'.+-- Returns 'Nothing' in the event that one of the values contains 'LLVMValUndef'+-- or 'LLVMValPoison'. testEqual :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym)           => sym -> LLVMVal sym -> LLVMVal sym -> IO (Maybe (Pred sym)) testEqual sym v1 v2 =@@ -394,6 +409,8 @@     (other, LLVMValZero tp) -> compareZero tp other     (LLVMValUndef _, _) -> pure Nothing     (_, LLVMValUndef _) -> pure Nothing+    (LLVMValPoison _, _) -> pure Nothing+    (_, LLVMValPoison _) -> pure Nothing     (_, _) -> false -- type mismatch    where true = pure (Just $ truePred sym)
src/Lang/Crucible/LLVM/MemType.hs view
@@ -52,9 +52,9 @@   , ppIdent   ) where -import Control.Lens import Data.Vector (Vector) import qualified Data.Vector as V+import Lens.Micro ((^.)) import Numeric.Natural import qualified Text.LLVM as L import Prettyprinter@@ -313,7 +313,7 @@              -> StructInfo mkStructInfo dl packed tps0 = go [] 0 a0 tps0   where a0 | packed    = noAlignment-           | otherwise = nextAlign noAlignment tps0 `max` aggregateAlignment dl+           | otherwise = nextAlign noAlignment tps0 `max` (dl ^. aggregateAlignment)         -- 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
src/Lang/Crucible/LLVM/QQ.hs view
@@ -15,7 +15,6 @@  module Lang.Crucible.LLVM.QQ  ( llvmType- , llvmDecl  , llvmOvr  ) where @@ -34,6 +33,7 @@ import qualified Data.Parameterized.Context as Ctx import           Lang.Crucible.Types import qualified Lang.Crucible.LLVM.Intrinsics.Common as IC+import qualified Lang.Crucible.LLVM.Intrinsics.Declare as Decl import           Lang.Crucible.LLVM.Types  -- | This type closely mirrors the type syntax from llvm-pretty,@@ -85,6 +85,7 @@ parseFloatType :: AT.Parser L.FloatType parseFloatType = AT.choice   [ pure L.Half      <* AT.string "half"+  , pure L.BFloat    <* AT.string "bfloat"   , pure L.Float     <* AT.string "float"   , pure L.Double    <* AT.string "double"   , pure L.Fp128     <* AT.string "fp128"@@ -252,19 +253,8 @@     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-      }-    |]+liftName :: Either String L.Symbol -> Q Exp+liftName nm = f nm   where   f (Left v)    = varE (mkName v)   f (Right sym) = lift sym@@ -301,6 +291,7 @@   liftFloatType ft = case ft of     L.Half      -> [| HalfFloatRepr |]     L.Float     -> [| SingleFloatRepr |]+    L.BFloat    -> fail "No support for Brain floats / bfloats yet"     L.Double    -> [| DoubleFloatRepr |]     L.Fp128     -> [| QuadFloatRepr |]     L.X86_fp80  -> [| X86_80FloatRepr |]@@ -316,8 +307,8 @@   liftQQDeclToOverride :: QQDeclare -> Q Exp-liftQQDeclToOverride qqd@(QQDeclare ret _nm args varargs) =-  [| IC.LLVMOverride $(liftQQDecl qqd) $(liftArgs args varargs) $(liftTypeRepr ret) |]+liftQQDeclToOverride (QQDeclare ret nm args varargs) =+  [| IC.LLVMOverride (Decl.Declare $(liftName nm) $(liftArgs args varargs) $(liftTypeRepr ret)) |]  -- | This quasiquoter parses values in LLVM type syntax, extended --   with metavariables, and builds values of @Text.LLVM.AST.Type@.@@ -339,31 +330,6 @@   , 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,
src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs view
@@ -28,7 +28,6 @@   , simpleLoopFixpoint   ) where -import           Control.Lens import           Control.Monad (when) import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Reader (ReaderT(..))@@ -36,6 +35,7 @@ import           Control.Monad.Trans.Maybe import           Data.Either import           Data.Foldable+import           Data.Function ((&)) import qualified Data.IntMap as IntMap import           Data.IORef import qualified Data.List as List@@ -43,6 +43,7 @@ import qualified Data.Map as Map import           Data.Map (Map) import qualified Data.Set as Set+import           Lens.Micro ((^.), (.~), (%~)) import qualified System.IO import           Numeric.Natural
src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs view
@@ -46,13 +46,14 @@   , simpleLoopFixpoint   ) where -import           Control.Lens import           Control.Monad import           Control.Monad.IO.Class import           Control.Monad.Reader import           Control.Monad.State import           Control.Monad.Trans.Maybe import           Data.Foldable+import           Data.Function ((&))+import           Data.Functor.Identity (runIdentity) import qualified Data.IntMap as IntMap import           Data.IORef import           Data.Kind@@ -64,6 +65,7 @@ import qualified Data.Set as Set import           Data.Set (Set) import           GHC.TypeLits (KnownNat)+import           Lens.Micro ((^.), (.~), (%~)) import           Numeric.Natural (Natural) import qualified System.IO
src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs view
@@ -97,13 +97,14 @@   , simpleLoopInvariant   ) where -import           Control.Lens import           Control.Monad (forM, unless, when) import           Control.Monad.IO.Class (MonadIO(..))+import           Data.Functor.Const (Const(..)) import           Control.Monad.Except (ExceptT, MonadError(..), runExceptT) import           Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT) import           Control.Monad.State (MonadState(..), StateT(..)) import           Data.Foldable+import           Data.Function ((&)) import qualified Data.IntMap as IntMap import           Data.IORef import qualified Data.List as List@@ -111,6 +112,7 @@ import qualified Data.Map as Map import           Data.Map (Map) import qualified Data.Set as Set+import           Lens.Micro ((^.), (.~), (%~)) import qualified System.IO import           Numeric.Natural import           Prettyprinter (pretty)@@ -462,9 +464,9 @@           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)-                       ]+  _ -> C.panic "applySubstitutionRegEntry"+       [ "unsupported type: " ++ show (C.regType entry)+       ]   loadMemJoinVariables ::
src/Lang/Crucible/LLVM/SymIO.hs view
@@ -102,6 +102,7 @@  import           Lang.Crucible.LLVM.Bytes (toBytes) import           Lang.Crucible.LLVM.MemModel+import qualified Lang.Crucible.LLVM.MemModel.Strings as CStr import           Lang.Crucible.LLVM.Extension ( ArchWidth ) import           Lang.Crucible.LLVM.DataLayout ( noAlignment ) import           Lang.Crucible.LLVM.Intrinsics@@ -380,7 +381,7 @@ loadFileIdent memOps filename_ptr =   ovrWithBackend $ \bak ->    do mem <- readGlobal memOps-      filename_bytes <- liftIO $ loadString bak mem filename_ptr Nothing+      filename_bytes <- liftIO $ CStr.loadString bak mem filename_ptr Nothing       liftIO $ W4.stringLit (backendGetSym bak) (W4.Char8Literal (BS.pack filename_bytes))  returnIOError32
src/Lang/Crucible/LLVM/Translation.hs view
@@ -92,16 +92,16 @@   , 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           Lens.Micro (SimpleGetter, to, (^.))+import           Lens.Micro.Mtl (use, (.=)) import           Prettyprinter (pretty)  import qualified Text.LLVM.AST as L@@ -167,19 +167,19 @@   testEquality mt1 mt2 =     testEquality (_modTransNonce mt1) (_modTransNonce mt2) -transContext :: Getter (ModuleTranslation arch) (LLVMContext arch)+transContext :: SimpleGetter (ModuleTranslation arch) (LLVMContext arch) transContext = to _transContext -globalInitMap :: Getter (ModuleTranslation arch) GlobalInitializerMap+globalInitMap :: SimpleGetter (ModuleTranslation arch) GlobalInitializerMap globalInitMap = to _globalInitMap -modTransDefs :: Getter (ModuleTranslation arch) [(L.Declare,SomeHandle)]+modTransDefs :: SimpleGetter (ModuleTranslation arch) [(L.Declare,SomeHandle)] modTransDefs = to _modTransDefs -modTransModule :: Getter (ModuleTranslation arch) L.Module+modTransModule :: SimpleGetter (ModuleTranslation arch) L.Module modTransModule = to _modTransModule -modTransHalloc :: Getter (ModuleTranslation arch) HandleAllocator+modTransHalloc :: SimpleGetter (ModuleTranslation arch) HandleAllocator modTransHalloc = to _modTransHalloc  typeToRegExpr :: MemType -> LLVMGenerator s arch ret (Some (Reg s))@@ -206,8 +206,8 @@           , fromString msg           ] -    stmt m (L.Effect _ _) = return m-    stmt m (L.Result ident instr _) = do+    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@@ -223,26 +223,25 @@ 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) =+generateStmts retType lab stmts = go (processDbgDeclare stmts)+ where go [] = fail "LLVM basic block ended without a terminating instruction"+       go (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+           L.Result ident instr dr md ->+              do setLocation md dr+                 generateInstr retType lab instr                    (assignLLVMReg ident)-                   (go (Set.insert ident defSet) xs)+                   (go 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+           L.Effect instr dr md ->+              do setLocation md dr+                 generateInstr retType lab instr                    (\_ -> return ())-                   (go defSet xs)+                   (go xs)  -- | Search for calls to intrinsic 'llvm.dbg.declare' and copy the -- metadata onto the corresponding 'alloca' statement.  Also copy@@ -255,18 +254,18 @@     go (stmt : stmts) =       let (m, stmts') = go stmts in       case stmt of-        L.Result x instr@L.Alloca{} md ->+        L.Result x instr@L.Alloca{} dr md ->           case Map.lookup x m of-            Just md' -> (m, L.Result x instr (md' ++ md) : stmts')+            Just md' -> (m, L.Result x instr dr (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 ->+        L.Result x (L.Conv L.BitCast (L.Typed _ (L.ValIdent y)) _) _dr 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 ->+        L.Effect (L.Call _ _ (L.ValSymbol "llvm.dbg.declare") (L.Typed _ (L.ValMd (L.ValMdValue (L.Typed _ (L.ValIdent x)))) : _)) _dr md ->           (Map.insert x md m, stmt : stmts')          -- This is needlessly fragile. Let's just ignore debug declarations we don't understand.@@ -275,25 +274,67 @@          _ -> (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-+-- | Search for an instruction's nearest debug location that was attached as a+-- metadata attribute using the @!dbg@ identifier, and then set the+-- `LLVMGenerator`'s position using the location. If such a metadata attribute+-- cannot be found, look at the debug records as a fallback. (In practice, LLVM+-- will usually attach debug locations as metadata attributes, so it makes more+-- sense to look through the metadata attributes first.)+setLocation ::+  forall s arch ret.+  -- | The metadata attributes.+  [(String,L.ValMd)] ->+  -- | The debug records.+  [L.DebugRecord] ->+  LLVMGenerator s arch ret ()+setLocation mds drs = setMetadataLocation mds  where+ setMetadataLocation :: [(String,L.ValMd)] -> LLVMGenerator s arch ret ()+ setMetadataLocation [] =+   -- If we can't find a @!dbg@ metadata location, fall back to searching the+   -- debug records.+   setDebugRecordLocation drs+ setMetadataLocation (x:xs) =+   case x of+     ("dbg",md)+       | Just posn <- valMdPosition md ->+         setPosition posn+     _ -> setMetadataLocation xs++ setDebugRecordLocation :: [L.DebugRecord] -> LLVMGenerator s arch ret ()+ setDebugRecordLocation [] = return ()+ setDebugRecordLocation (x:xs) =+   case x of+     L.DebugRecordValue drv+       | Just posn <- valMdPosition (L.drvLocation drv) ->+         setPosition posn+     L.DebugRecordValueSimple drvs+       | Just posn <- valMdPosition (L.drvsLocation drvs) ->+         setPosition posn+     L.DebugRecordDeclare drd+       | Just posn <- valMdPosition (L.drdLocation drd) ->+         setPosition posn+     L.DebugRecordAssign dra+       | Just posn <- valMdPosition (L.draLocation dra) ->+         setPosition posn+     L.DebugRecordLabel drl+       | Just posn <- valMdPosition (L.drlLocation drl) ->+         setPosition posn+     _ -> setDebugRecordLocation xs++ valMdPosition :: L.ValMd -> Maybe Position+ valMdPosition (L.ValMdLoc dl) =+   let ln   = fromIntegral $ L.dlLine dl+       col  = fromIntegral $ L.dlCol dl+       file = getFile $ L.dlScope dl+    in Just (SourcePos file ln col)+ valMdPosition (L.ValMdDebugInfo (L.DebugInfoSubprogram subp))+   | Just file' <- L.dispFile subp =+     let ln = fromIntegral $ L.dispLine subp+         file = getFile file'+     in Just (SourcePos file ln 0)+ valMdPosition _ = Nothing+  getFile = Text.pack . maybe "" filenm . findFile   -- The typical values available here will be something like:@@ -353,7 +394,7 @@         -> 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)+    Just bi -> defineBlock (block_label bi) (generateStmts retType lab stmts)     Nothing -> fail $ unwords ["LLVM basic block not found in block info map", show lab]  defineLLVMBlock _ _ _ = fail "LLVM basic block has no label!"@@ -375,7 +416,7 @@     ( 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)+      setLocation (Map.toList (L.defMetadata defn)) []        bim <- buildBlockInfoMap defn       blockInfoMap .= bim
src/Lang/Crucible/LLVM/Translation/Aliases.hs view
@@ -115,7 +115,7 @@         -- 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 (Left _)  = panic "reverseAliasesTwoSorted" ["unexpected Left value"]         errLeft (Right v) = v  -- | What does this alias point to?
src/Lang/Crucible/LLVM/Translation/BlockInfo.hs view
@@ -25,7 +25,7 @@   ) where  import Data.Foldable (toList)-import Data.List (foldl')+import qualified Data.Foldable as Foldable import Data.Maybe import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -131,7 +131,7 @@  -- | Compute predecessor sets from the successor sets already computed in @buildBlockInfo@ updatePredSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s-updatePredSets bim0 = foldl' upd bim0 predEdges+updatePredSets bim0 = Foldable.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 @@ -190,7 +190,7 @@   -- to registers: the return values can only be used in the "normal" successor   -- block. -  loop (L.Result nm i _md:ss) =+  loop (L.Result nm i _dr _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@@ -214,7 +214,7 @@       -- 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)+  loop (L.Effect i _dr _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@@ -237,7 +237,7 @@   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.ICmp _samesign _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 ]@@ -286,9 +286,13 @@ useVal v = Set.unions $ case v of   L.ValInteger{} ->  []   L.ValBool{} -> []+  L.ValHalf{} -> []+  L.ValBFloat{} -> []   L.ValFloat{} -> []   L.ValDouble{} -> []   L.ValFP80{} -> []+  L.ValFP128{} -> []+  L.ValFP128_PPC{} -> []   L.ValIdent i -> [Set.singleton i]   L.ValSymbol _s -> []   L.ValNull -> []@@ -312,7 +316,7 @@ -- 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)+ 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)
src/Lang/Crucible/LLVM/Translation/Constant.hs view
@@ -49,10 +49,10 @@      -- * Utility functions   , showInstr-  , testBreakpointFunction+  , testCutpointFunction   ) where -import           Control.Lens( to, (^.) )+import qualified Control.Exception as X import           Control.Monad import           Control.Monad.Except import           Data.ByteString (ByteString)@@ -63,6 +63,7 @@ import           Data.Traversable import           Data.Fixed (mod') import qualified Data.Vector as V+import           Lens.Micro ((^.), to) import           Numeric.Natural import           GHC.TypeNats @@ -73,7 +74,6 @@ 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(..) )@@ -85,7 +85,7 @@  -- | Pretty print an LLVM instruction showInstr :: L.Instr -> String-showInstr i = show (L.ppLLVM38 (L.ppInstr i))+showInstr i = show (LPP.ppLLVMLatest (L.ppInstr i))  -- | Intermediate representation of a GEP. --   A @GEP n expr@ is a representation of a GEP with@@ -152,8 +152,7 @@ -- types, computing vectorization lanes, etc. -- -- As a concrete example, consider a call to--- @'translateGEP' inbounds baseTy basePtr elts@ with the following--- instruction:+-- @'translateGEP' attrs baseTy basePtr elts@ with the following instruction: -- -- @ -- getelementptr [12 x i8], ptr %aptr, i64 0, i32 1@@ -161,8 +160,10 @@ -- -- Here: ----- * @inbounds@ is 'False', as the keyword of the same name is missing from---   the instruction. (Currently, @crucible-llvm@ ignores this information.)+-- * @attrs@ is @[]@, as there are no @inbounds@, @nusw@, @nuw@, or @inrange@+--   attributes used in the instruction. (Currently, @crucible-llvm@ ignores+--   attribute information. See+--   <https://github.com/GaloisInc/crucible/issues/1605>.) -- -- * @baseTy@ is @[12 x i8]@. This is the type used as the basis for --   subsequent calculations.@@ -175,7 +176,7 @@ --   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.GEPAttr]       {- ^ attributes -} ->   L.Type            {- ^ base type for calculations -} ->   L.Typed L.Value   {- ^ base pointer expression -} ->   [L.Typed L.Value] {- ^ index arguments -} ->@@ -184,7 +185,7 @@ translateGEP _ _ _ [] =   throwError "getelementpointer must have at least one index" -translateGEP inbounds baseTy basePtr elts =+translateGEP attrs 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@@ -209,7 +210,7 @@          -> badGEP  where  badGEP :: m a- badGEP = throwError $ unlines [ "Invalid GEP", showInstr (L.GEP inbounds baseTy basePtr elts) ]+ badGEP = throwError $ unlines [ "Invalid GEP", showInstr (L.GEP attrs 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@@ -337,6 +338,9 @@   -- | The @undef@ value is quite strange. See: The LLVM Language Reference,   -- § Undefined Values.   UndefConst    :: !MemType -> LLVMConst+  -- | The @poison@ value is quite strange. See: The LLVM Language Reference,+  -- § Poison Values.+  PoisonConst   :: !MemType -> LLVMConst   -- | This also can't be derived, but is completely uninteresting.@@ -353,29 +357,9 @@       (StructConst si a)  -> ["StructConst", show si, show a]       (SymbolConst s x)   -> ["SymbolConst", show s, show x]       (UndefConst mem)    -> ["UndefConst", show mem]+      (PoisonConst mem)   -> ["PoisonConst", 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)@@ -423,6 +407,8 @@   m LLVMConst transConstant' tp (L.ValUndef) =   return (UndefConst tp)+transConstant' tp (L.ValPoison) =+  return (PoisonConst tp) transConstant' (IntType n) (L.ValInteger x) =   intConst n x transConstant' (IntType 1) (L.ValBool b) =@@ -805,14 +791,19 @@       , DoubleConst d <- x       -> return $ IntConst w (BV.mkBV w (truncate d)) -    L.UiToFp+    L.UiToFp nneg       | FloatType <- mt       , IntConst _w i <- x-      -> return $ FloatConst (fromInteger (BV.asUnsigned i) :: Float)+      -> -- LLVM does not currently enable the `nneg` flag in constant+         -- expressions, only in instructions. As such, we don't use the flag+         -- below except to assert that it's disabled.+         X.assert (not nneg) $+         return $ FloatConst (fromInteger (BV.asUnsigned i) :: Float)        | DoubleType <- mt       , IntConst _w i <- x-      -> return $ DoubleConst (fromInteger (BV.asUnsigned i) :: Double)+      -> X.assert (not nneg) $+         return $ DoubleConst (fromInteger (BV.asUnsigned i) :: Double)      L.SiToFp       | FloatType <- mt@@ -823,23 +814,32 @@       , IntConst w i <- x       -> return $ DoubleConst (fromInteger (BV.asSigned w i) :: Double) -    L.Trunc+    L.Trunc nuw nsw       | IntType n <- mt       , IntConst w i <- x       , Just (Some w') <- someNat n       , Just LeqProof <- isPosNat w'-      -> case testNatCases w' w of+      -> -- LLVM does not currently enable the `nuw` or `nsw` flags in constant+         -- expressions, only in instructions. As such, we don't use the flags+         -- below except to assert that they're disabled.+         X.assert (not nuw) $+         X.assert (not nsw) $+         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+    L.ZExt nneg       | IntType n <- mt       , IntConst w i <- x       , Just (Some w') <- someNat n       , Just LeqProof <- isPosNat w'-      -> case testNatCases w w' of+      -> -- LLVM does not currently enable the `nneg` flag in constant+         -- expressions, only in instructions. As such, we don't use the flag+         -- below except to assert that it's disabled.+         X.assert (not nneg) $+         case testNatCases w w' of           NatCaseLT LeqProof -> return $ IntConst w' (BV.zext w' i)           NatCaseEQ -> return x           NatCaseGT LeqProof ->@@ -1085,8 +1085,8 @@   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+  L.ConstGEP attrs _inrange baseTy base exps -> -- TODO(#1605)? pay attention to the inrange flag+    do gep <- translateGEP attrs baseTy base exps        gep' <- traverse transConstant gep        snd <$> evalConstGEP gep' @@ -1200,5 +1200,5 @@  badExp :: String -> m a  badExp msg = throwError $ unlines [msg, show expr] -testBreakpointFunction :: String -> Bool-testBreakpointFunction = isPrefixOf "__breakpoint__"+testCutpointFunction :: String -> Bool+testCutpointFunction = isPrefixOf "__cutpoint__"
src/Lang/Crucible/LLVM/Translation/Expr.hs view
@@ -35,12 +35,15 @@   , pattern PointerExpr   , pattern BitvectorAsPointerExpr   , pointerAsBitvectorExpr+  , poisonBvExpr+  , poisonFloatExpr    , unpackOne   , unpackVec   , unpackArgs   , zeroExpand   , undefExpand+  , poisonExpand   , explodeVector    , constToLLVMVal@@ -60,7 +63,6 @@   , callStore   ) where -import Control.Lens hiding ((:>)) import Control.Monad import Control.Monad.Except import qualified Data.ByteString as BS@@ -72,6 +74,7 @@ import qualified Data.Sequence as Seq import Data.String import qualified Data.Vector as V+import           Lens.Micro.Mtl (use) import Numeric.Natural import GHC.Exts ( Proxy#, proxy# ) @@ -121,6 +124,7 @@    BaseExpr   :: TypeRepr tp -> Expr LLVM s tp -> LLVMExpr s arch    ZeroExpr   :: MemType -> LLVMExpr s arch    UndefExpr  :: MemType -> LLVMExpr s arch+   PoisonExpr :: MemType -> LLVMExpr s arch    VecExpr    :: MemType -> Seq (LLVMExpr s arch) -> LLVMExpr s arch    StructExpr :: Seq (MemType, LLVMExpr s arch) -> LLVMExpr s arch @@ -128,6 +132,7 @@   show (BaseExpr ty x)  = C.showF x ++ " : " ++ show ty   show (ZeroExpr mt)    = "<zero :" ++ show mt ++ ">"   show (UndefExpr mt)   = "<undef :" ++ show mt ++ ">"+  show (PoisonExpr mt)  = "<poison :" ++ 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@@ -150,6 +155,9 @@ asScalar (UndefExpr llvmtp)   = let ?err = error      in undefExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex+asScalar (PoisonExpr llvmtp)+  = let ?err = error+     in poisonExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex asScalar _ = NotScalar  -- | Turn the expression into an explicit vector.@@ -158,6 +166,7 @@   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))+    PoisonExpr (VecType n t) -> Just (t, Seq.replicate (fromIntegral n) (PoisonExpr t))     VecExpr t s             -> Just (t, s)     _                       -> Nothing @@ -198,8 +207,18 @@                 (litExpr "Expected bitvector, but found pointer")      return off +poisonBvExpr ::+  (1 <= w) =>+  NatRepr w ->+  Expr LLVM s (BVType w)+poisonBvExpr w = App (ExtensionApp (LLVM_PoisonBV w)) +poisonFloatExpr ::+  FloatInfoRepr fi ->+  Expr LLVM s (FloatType fi)+poisonFloatExpr fi = App (ExtensionApp (LLVM_PoisonFloat fi)) + -- | Given a list of LLVMExpressions, "unpack" them into an assignment --   of crucible expressions. unpackArgs :: forall s a arch@@ -225,6 +244,7 @@    -> a unpackOne (BaseExpr tyr ex) k = k proxy# tyr ex unpackOne (UndefExpr tp) k = undefExpand proxy# tp k+unpackOne (PoisonExpr tp) k = poisonExpand 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 ->@@ -284,36 +304,103 @@             -> 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'+undefExpand archProxy t k =+  case t of+    IntType w ->+      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]+        _ -> ?err $ unwords ["illegal integer size", show w]+    PtrType _tp ->+      k proxy# PtrRepr $+        BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth+    PtrOpaqueType ->+      k proxy# PtrRepr $+        BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth+    StructType si ->+      unpackArgs (map UndefExpr tps) $ \structArchProxy ctx asgn ->+        k structArchProxy (StructRepr ctx) (mkStruct ctx asgn)+      where tps = map fiType $ toList $ siFields si+    ArrayType n tp ->+      llvmTypeAsRepr tp $ \tpr ->+        unpackVec+          archProxy+          tpr+          (replicate (fromIntegral n) (UndefExpr tp))+          (k proxy# (VectorRepr tpr))+    VecType n tp ->+      llvmTypeAsRepr tp $ \tpr ->+        unpackVec+          archProxy+          tpr+          (replicate (fromIntegral n) (UndefExpr tp))+          (k proxy# (VectorRepr tpr))+    FloatType ->+      k proxy# (FloatRepr SingleFloatRepr) (App (FloatUndef SingleFloatRepr))+    DoubleType ->+      k proxy# (FloatRepr DoubleFloatRepr) (App (FloatUndef DoubleFloatRepr))+    X86_FP80Type ->+      k proxy# (FloatRepr X86_80FloatRepr) (App (FloatUndef X86_80FloatRepr))+    MetadataType ->+      ?err $ unwords ["cannot undef expand metadata type"] +poisonExpand :: ( ?err :: String -> a+                , HasPtrWidth (ArchWidth arch)+                )+             => Proxy# arch+             -> MemType+             -> (forall tp. Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> a)+             -> a+poisonExpand archProxy t k =+  case t of+    IntType w ->+      case mkNatRepr w of+        Some w' | Just LeqProof <- isPosNat w' ->+          k proxy# (LLVMPointerRepr w') $+             BitvectorAsPointerExpr w' $+             poisonBvExpr w' +        _ -> ?err $ unwords ["illegal integer size", show w]+    PtrType _tp ->+      k proxy# PtrRepr $+        BitvectorAsPointerExpr PtrWidth $ poisonBvExpr PtrWidth+    PtrOpaqueType ->+      k proxy# PtrRepr $+        BitvectorAsPointerExpr PtrWidth $ poisonBvExpr PtrWidth+    StructType si ->+      unpackArgs (map PoisonExpr tps) $ \structArchProxy ctx asgn ->+        k structArchProxy (StructRepr ctx) (mkStruct ctx asgn)+      where tps = map fiType $ toList $ siFields si+    ArrayType n tp ->+      llvmTypeAsRepr tp $ \tpr ->+        unpackVec+          archProxy+          tpr+          (replicate (fromIntegral n) (PoisonExpr tp))+          (k proxy# (VectorRepr tpr))+    VecType n tp ->+      llvmTypeAsRepr tp $ \tpr ->+        unpackVec+          archProxy+          tpr+          (replicate (fromIntegral n) (PoisonExpr tp))+          (k proxy# (VectorRepr tpr))+    FloatType ->+      k proxy# (FloatRepr SingleFloatRepr) (poisonFloatExpr SingleFloatRepr)+    DoubleType ->+      k proxy# (FloatRepr DoubleFloatRepr) (poisonFloatExpr DoubleFloatRepr)+    X86_FP80Type ->+      k proxy# (FloatRepr X86_80FloatRepr) (poisonFloatExpr X86_80FloatRepr)+    MetadataType ->+      ?err $ unwords ["cannot poison expand metadata type"]++ 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 (PoisonExpr (VecType n' tp)) | n == n' = return (Seq.replicate (fromIntegral n) (PoisonExpr 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@@ -335,6 +422,8 @@     return $ ZeroExpr mt   UndefConst mt ->     return $ UndefExpr mt+  PoisonConst mt ->+    return $ PoisonExpr mt   IntConst w i ->     return $ BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w (App (BVLit w i)))   FloatConst f ->@@ -395,6 +484,9 @@  transValue ty L.ValUndef =   return $ UndefExpr ty++transValue ty L.ValPoison =+  return $ PoisonExpr ty  transValue ty L.ValZeroInit =   return $ ZeroExpr ty
src/Lang/Crucible/LLVM/Translation/Instruction.hs view
@@ -38,8 +38,8 @@  import           Prelude hiding (exp, pred) -import           Control.Lens hiding (op, (:>) ) import           Control.Monad (MonadPlus(..), forM, unless)+import           Data.Functor.Identity (runIdentity) import           Control.Monad.Except (MonadError(..), runExceptT) import           Control.Monad.State.Strict (MonadState(..)) import           Control.Monad.Trans.Class (MonadTrans(..))@@ -51,13 +51,13 @@ 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           Lens.Micro ((^.))+import           Lens.Micro.Mtl (use) import           Numeric.Natural import           Prettyprinter (pretty) import GHC.Exts ( Proxy#, proxy# )@@ -81,7 +81,6 @@ 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@@ -159,7 +158,7 @@     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+    L.ICmp _samesign _op tv _ -> do       inpType <- liftMemType (L.typedType tv)       case inpType of         VecType len _ -> return (VecType len (IntType 1))@@ -171,8 +170,8 @@         _ -> return (IntType 1)     L.Phi tp _   -> liftMemType tp -    L.GEP inbounds baseTy basePtr elts ->-       do gepRes <- runExceptT (translateGEP inbounds baseTy basePtr elts)+    L.GEP attrs baseTy basePtr elts ->+       do gepRes <- runExceptT (translateGEP attrs baseTy basePtr elts)           case gepRes of             Left err -> throwError err             Right (GEPResult lanes tp _gep) ->@@ -237,10 +236,14 @@     -> LLVMGenerator s arch ret (LLVMExpr s arch) extractElt _instr ty _n (UndefExpr _) _i =    return $ UndefExpr ty+extractElt _instr ty _n (PoisonExpr _) _i =+   return $ PoisonExpr ty extractElt _instr ty _n (ZeroExpr _) _i =    return $ ZeroExpr ty extractElt _ ty _ _ (UndefExpr _) =    return $ UndefExpr ty+extractElt _ ty _ _ (PoisonExpr _) =+   return $ PoisonExpr 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)@@ -293,12 +296,16 @@     -> LLVMGenerator s arch ret (LLVMExpr s arch) insertElt _ ty _ _ _ (UndefExpr _) = do    return $ UndefExpr ty+insertElt _ ty _ _ _ (PoisonExpr _) = do+   return $ PoisonExpr 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 (PoisonExpr _) a i  = do+  insertElt instr ty n (VecExpr ty (Seq.replicate (fromInteger n) (PoisonExpr 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 @@ -357,6 +364,11 @@  where tps = map fiType $ toList $ siFields si extractValue (UndefExpr (ArrayType n tp)) is =    extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (UndefExpr tp)) is+extractValue (PoisonExpr (StructType si)) is =+   extractValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, PoisonExpr tp)) tps) is+ where tps = map fiType $ toList $ siFields si+extractValue (PoisonExpr (ArrayType n tp)) is =+   extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (PoisonExpr 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@@ -390,6 +402,11 @@  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 (PoisonExpr (StructType si)) v is =+   insertValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, PoisonExpr tp)) tps) v is+ where tps = map fiType $ toList $ siFields si+insertValue (PoisonExpr (ArrayType n tp)) v is =+   insertValue (VecExpr tp $ Seq.replicate (fromIntegral n) (PoisonExpr 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@@ -533,8 +550,8 @@              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.+               -- instructions as if they had the `inbounds` attribute set, so+               -- the result would be a poison value.                poisonSideCondition mvar (BVRepr PtrWidth) poison off0 cond       -- Perform the pointer offset arithmetic@@ -575,8 +592,10 @@   | 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+translateConversion instr op _inty x outty = do+ mvar <- getMemVar+ let showI = showInstr instr+ let noLaxArith = not (laxArith ?transOpts)  case op of     L.IntToPtr -> do        llvmTypeAsRepr outty $ \outty' ->@@ -599,26 +618,46 @@               , Just Refl <- testEquality w' PtrWidth -> return x            _ -> fail (unlines ["pointer-to-integer conversion failed", showI]) -    L.Trunc -> do+    L.Trunc nuw nsw -> 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'))+                    bv' <- AtomExpr <$> mkAtom (App (BVTrunc w' w x_bv))+                    result <- sideConditionsA mvar (BVRepr w') bv'+                      [ ( nuw && noLaxArith+                        , fmap (App . BVEq w x_bv . AtomExpr)+                               (mkAtom (App (BVZext w w' bv')))+                        , UB.PoisonValueCreated $ Poison.TruncNoUnsignedWrap x_bv+                        )+                      , ( nsw && noLaxArith+                        , fmap (App . BVEq w x_bv . AtomExpr)+                               (mkAtom (App (BVSext w w' bv')))+                        , UB.PoisonValueCreated $ Poison.TruncNoSignedWrap x_bv+                        )+                      ]+                    return (BaseExpr outty' (BitvectorAsPointerExpr w' result))            _ -> fail (unlines [unwords ["invalid truncation:", show x, show outty], showI]) -    L.ZExt -> do+    L.ZExt nneg -> 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'))+                    bv' <- AtomExpr <$> mkAtom (App (BVZext w' w x_bv))+                    let z = App $ BVLit w $ BV.zero w+                    result <-+                      sideConditionsA mvar (BVRepr w') bv'+                        [ ( nneg+                          , pure $ App $ BVSle w z x_bv+                          , UB.PoisonValueCreated $ Poison.ZExtNonNegative x_bv+                          )+                        ]+                    return (BaseExpr outty' (BitvectorAsPointerExpr w' result))            _ -> fail (unlines [unwords ["invalid zero extension:", show x, show outty], showI])      L.SExt -> do@@ -638,12 +677,21 @@     L.BitCast -> bitCast _inty x outty #endif -    L.UiToFp -> do+    L.UiToFp nneg -> 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+             bvFp <- AtomExpr <$> mkAtom (App (FloatFromBV fi RNE bv))+             let z = App $ BVLit w $ BV.zero w+             result <-+               sideConditionsA mvar outty' bvFp+                 [ ( nneg+                   , pure $ App $ BVSle w z bv+                   , UB.PoisonValueCreated $ Poison.UiToFpNonNegative bv+                   )+                 ]+             return $ BaseExpr (FloatRepr fi) result            _ -> fail (unlines [unwords ["Invalid uitofp:", show op, show x, show outty], showI])      L.SiToFp -> do@@ -655,19 +703,41 @@            _ -> 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'+           (Scalar _archProxy (FloatRepr fi) x', LLVMPointerRepr w) -> do+             -- See Note [Checking for undefined behavior in fptoui and fptosi]+             xBv <- fmap AtomExpr $ mkAtom $ app $ FloatToBV w RTZ x'+             xRoundtrip <- fmap AtomExpr $ mkAtom $ app $ FloatFromBV fi RTZ xBv+             xRounded <- fmap AtomExpr $ mkAtom $ app $ FloatRound fi RTZ x'+             let noOverflow = app $ Or (app (FloatIsZero xRounded))+                                       (app (FloatEq xRoundtrip xRounded))+                 result = poisonSideCondition+                            mvar+                            (BVRepr w)+                            (Poison.FpToUiNotRepresentable fi x' w)+                            xBv+                            noOverflow+             return $ BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w result)            _ -> 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'+           (Scalar _archProxy (FloatRepr fi) x', LLVMPointerRepr w) -> do+             -- See Note [Checking for undefined behavior in fptoui and fptosi]+             xBv <- fmap AtomExpr $ mkAtom $ app $ FloatToSBV w RTZ x'+             xRoundtrip <- fmap AtomExpr $ mkAtom $ app $ FloatFromSBV fi RTZ xBv+             xRounded <- fmap AtomExpr $ mkAtom $ app $ FloatRound fi RTZ x'+             let noOverflow = app $ Or (app (FloatIsZero xRounded))+                                       (app (FloatEq xRoundtrip xRounded))+                 result = poisonSideCondition+                            mvar+                            (BVRepr w)+                            (Poison.FpToSiNotRepresentable fi x' w)+                            xBv+                            noOverflow+             return $ BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w result)            _ -> fail (unlines [unwords ["Invalid fptosi:", show op, show x, show outty], showI])      L.FpTrunc -> do@@ -684,7 +754,113 @@              return $ BaseExpr (FloatRepr fi) $ App $ FloatCast fi RNE x'            _ -> fail (unlines [unwords ["Invalid fpext:", show op, show x, show outty], showI]) +{-+Note [Checking for undefined behavior in fptoui and fptosi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `fptoui` and `fptosi` instructions convert a floating-point argument to an+unsigned or signed integer value, respectively. Per the LLVM Language Reference+Manual entries for `fptoui`+(https://releases.llvm.org/22.1.0/docs/LangRef.html#fptoui-to-instruction) and+`fptosi`+(https://releases.llvm.org/22.1.0/docs/LangRef.html#fptosi-to-instruction),+these instructions are partial and should return a poison value if the argument+value cannot fit in the return type. For instance, `fptoui` should return a+poison value if the argument value is NaN, infinite, is smaller than 0, or is+larger than the maximum unsigned integer value. +Note that Crucible's `FloatToBV` and `FloatToSBV` operations (which we use to+implement `fptoui` and `fptosi`, respectively) do not check these edge cases,+and they will simply return an unspecified value if the argument does not fit+in the return type. (This behavior is inherited from SMT-LIB's `fp.to_ubv` and+`fp.to_sbv` operations, which also return unspecified values if the argument+does not fit.) As such, we must check the edge cases during crucible-llvm's+translation in order to ensure that undefined behavior is reported as expected.++Checking for NaN values or infinite values is straightforward enough, but+checking if a float lies within the range of valid unsigned or signed integer+values is surprisingly tricky. A naïve approach would be to convert the float+to an integer (using `FloatTo{BV,SBV}`) and check to see if (1) it is greater+than or equal to the minimum possible integer value, and (2) it is less than or+equal to the maximum possible integer value. As noted above, however, if the+float lies outside this range, then `FloatTo{BV,SBV}` is free to return+whatever integer value it likes. This, in turn, can produce misleading results+if you try to compare it to the minimum/maximum integer values.++Another approach, which avoids the use of `FloatTo{BV,SBV}` for validation+purposes, is to convert the argument float, the minimum integer value, and the+maximum integer value to unbounded integers, and then check if the converted+float lies within the range of possible bitvector values by using unbounded+integer comparisons. There is no risk of unspecified conversion results here,+as converting floats to unbounded integers is always well-defined. There are+two notable downsides to this approach, however:++1. This requires SMT-LIB's Ints theory, which is not supported by all SMT+   solvers (e.g., Bitwuzla). Indeed, it's pretty surprising that `fpto{ui,si}`+   would need unbounded integers, as nothing about the types of these+   instructions would suggest this.++2. Even if we restrict ourselves to solvers that do support unbounded integers+   (e.g., CVC5 and Z3), these solvers' performance on unbounded integer+   problems is usually much worse than problems that exclusively use bitvector+   or floating-point types.++Luckily, there is a third approach that is both correct and avoids the use of+unbounded integers. The algorithm for checking the validity of `fpto{ui,si}` on+an argument float `val` is as follows:++1. If `val` is zero, then the cast is valid.+2. Otherwise:+  a. Compute `bv` by converting `val` to a bitvector using Crucible's+     `FloatTo{BV,SBV}` operation with the RTZ (rounding towards zero) rounding+     mode.+  b. Compute `fp2` by converting `bv` back to a float using Crucible's+     `FloatFrom{BV,SBV}` operation with the RTZ rounding mode.+  c. Compute `val_rounded` by rounding `val` to the nearest integral value+     that is representable in the `val`'s floating-point type. This is done by+     using Crucible's `FloatRound` operation with the RTZ (rounding towards+     zero) rounding mode.+  d. If `fp2` equals `val_rounded` (according to logical floating-point+     equality, i.e., Crucible's `FloatEq` operation), then the cast is valid.+     Otherwise, it is invalid.++Here is an argument for why this algorithm is correct:++* As noted above, it is possible for `FloatTo{BV,SBV}` to return an unspecified+  value if `val` lies outside the range of possible bitvectors. Steps (2)(b)+  through (2)(d) are crucial for preventing unspecified values from producing+  misleading results. Note that `FloatFrom{BV,SBV}` and `FloatRound` are+  well-defined for all possible inputs, and because we are using the RTZ+  rounding mode, they will never round a float up to positive infinity or down+  to negative infinity. Moreover, `FloatFrom{BV,SBV}` will always return a+  float that lies within the range of valid bitvectors.++  If the equality check in step (2)(d) succeeds, then we know that+  `FromTo{BV,SBV}` did not take a float lying outside the range of valid+  bitvectors and turn it into a completely different bitvector. If it did, then+  `FloatFrom{BV,SBV}` would produce a different float than what `FloatRound`+  would produce. It is worth emphasizing that this trick only works with the+  RTZ rounding mode, but thankfully, that is exactly the rounding mode that+  `fpto{ui,si}` requires.++* Why the special case for zero values in step (1)? It's because calling+  `FloatTo{BV,SBV}` on negative zero will drop the negative sign, so converting+  it back to a float with `FloatFrom{BV,SBV}` will return positive zero. On the+  other hand, calling `FloatRound` on negative zero will return negative zero,+  which is deemed logically unequal to positive zero.++  An alternative approach would be to use IEEE floating-point equality (i.e.,+  Crucible's `FloatFpEq` operation) instead of logical equality (i.e., the+  `FloatEq` operation) in step (2)(d), as the former equates positive and+  negative zero. On the other hand, we would need to change step (1) to add a+  special case for NaN values, since NaN is deemded unequal to itself according+  to IEEE equality. Either way, you need a special case of some sort.++This approach is directly inspired by how the Alive2 translation validation+tool for LLVM translates `fpto{ui,si}`. See+https://github.com/AliveToolkit/alive2/blob/efddfc43bae2760cb5878b932a9c1a001fec374e/ir/instr.cpp#L2048-L2106+-}++ -------------------------------------------------------------------------------- -- Bit Cast @@ -699,6 +875,8 @@  bitCast _ (UndefExpr _) tgtT = return (UndefExpr tgtT) +bitCast _ (PoisonExpr _) tgtT = return (PoisonExpr tgtT)+ -- pointer casts always succeed bitCast (PtrType _) expr (PtrType _) = return expr bitCast (PtrType _) expr PtrOpaqueType = return expr@@ -1269,25 +1447,30 @@   integerCompare ::+  -- ^ If 'True', require that the arguments have the same sign.+  Bool ->   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 samesign op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) =+  VecExpr (IntType 1) <$> sequence (Seq.zipWith (\x y -> integerCompare samesign op tp x y) xs ys) -integerCompare op _ x y = do-  b <- scalarIntegerCompare op x y+integerCompare samesign op _ x y = do+  b <- scalarIntegerCompare samesign op x y   return (BaseExpr (LLVMPointerRepr (knownNat :: NatRepr 1))                    (BitvectorAsPointerExpr knownNat (App (BoolToBV knownNat b))))  scalarIntegerCompare ::+  -- ^ If 'True', require that the arguments have the same sign.+  Bool ->   L.ICmpOp ->   LLVMExpr s arch ->   LLVMExpr s arch ->   LLVMGenerator s arch ret (Expr LLVM s BoolType)-scalarIntegerCompare op x y =+scalarIntegerCompare samesign op x y = do+  mvar <- getMemVar   case (asScalar x, asScalar y) of     (Scalar _archProxy (LLVMPointerRepr w) x'', Scalar _archProxy' (LLVMPointerRepr w') y'')        | Just Refl <- testEquality w w'@@ -1296,7 +1479,14 @@        | Just Refl <- testEquality w w'        -> do xbv <- pointerAsBitvectorExpr w x''              ybv <- pointerAsBitvectorExpr w y''-             return (intcmp w op xbv ybv)+             result <- AtomExpr <$> mkAtom (intcmp w op xbv ybv)+             let z = App $ BVLit w $ BV.zero w+             sideConditionsA mvar BoolRepr result+               [ ( samesign+                 , pure $ App $ BoolEq (App (BVSlt w xbv z)) (App (BVSlt w ybv z))+                 , UB.PoisonValueCreated $ Poison.ICmpSameSign xbv ybv+                 )+               ]     _ -> fail $ unlines [ "arithmetic comparison on incompatible values"                         , "Comparison: " ++ show op                         , "Value 1: " ++ show x@@ -1512,7 +1702,6 @@    (?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 -} ->@@ -1521,7 +1710,7 @@           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 =+generateInstr retType lab instr assign_f k =   case instr of     -- skip phi instructions, they are handled in definePhiBlock     L.Phi _ _ -> k@@ -1589,6 +1778,7 @@                  do let getV x =                           case x of                             UndefExpr _ -> return $ UndefExpr elTy+                            PoisonExpr _ -> return $ PoisonExpr 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))@@ -1669,11 +1859,14 @@       callStore vTp ptr' v' align'       k -    -- NB We treat every GEP as though it has the "inbounds" flag set;+    -- NB We treat every GEP as though it has the "inbounds" attribute 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+    --+    --    TODO(#1605): Don't error immediately if the "inbounds" attribute isn't+    --    set.+    L.GEP attrs baseTy basePtr elts -> do+      runExceptT (translateGEP attrs baseTy basePtr elts) >>= \case         Left err -> reportError $ fromString $ unlines ["Error translating GEP", err]         Right gep ->           do gep' <- traverse (\v -> transTypedValue v) gep@@ -1690,14 +1883,14 @@          k      L.Call tailcall fnTy fn args ->-      callFunction defSet instr tailcall fnTy fn args assign_f >> k+      callFunction 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+      do callFunction 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+      do callFunction instr False fnTy fn args assign_f          for_ otherLabels $ \lab' -> void (definePhiBlock lab lab')          definePhiBlock lab normLabel @@ -1732,11 +1925,11 @@            assign_f cmp            k -    L.ICmp op x y -> do+    L.ICmp samesign 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'+           cmp <- integerCompare samesign op tp x' y'            assign_f cmp            k @@ -1801,7 +1994,7 @@                let a0 = memTypeAlign (llvmDataLayout ?lc) resTy               oldVal <- callLoad resTy expectTy ptr' a0-              cmp <- scalarIntegerCompare L.Ieq oldVal cmpVal+              cmp <- scalarIntegerCompare False L.Ieq oldVal cmpVal               let flag = BaseExpr (LLVMPointerRepr (knownNat @1))                                   (BitvectorAsPointerExpr knownNat                                      (App (BoolToBV knownNat cmp)))@@ -1961,7 +2154,7 @@          return $ App $ FloatNeg fi a  -- | Generate a call to an LLVM function, without any special---   handling for debug intrinsics or breakpoints.+--   handling for debug intrinsics or cuts/cutpoints. callOrdinaryFunction ::    Maybe L.Instr {- ^ The instruction causing this call -} ->    Bool    {- ^ Is the function a tail call? -} ->@@ -2001,10 +2194,9 @@   -- | Generate a call to an LLVM function, generating special support--- for debugging intrinsics and breakpoint functions.+-- for debugging intrinsics and cuts/cutpoint 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 -} ->@@ -2012,42 +2204,8 @@    [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.+callFunction instr tailCall_ fnTy fn args assign_f+     -- Skip calls to debugging intrinsics.      | L.ValSymbol nm <- fn      , nm `elem` [ "llvm.dbg.label"                  , "llvm.dbg.declare"@@ -2070,41 +2228,14 @@                  ] = return ()       | L.ValSymbol (L.Symbol nm) <- fn-     , testBreakpointFunction nm = do+     , testCutpointFunction 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+            addCutStmt (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))@@ -2117,7 +2248,7 @@       Nothing -> reportError $ fromString $         "Could not find identifier " ++ show i ++ "."   v -> reportError $ fromString $-    "Unsupported breakpoint parameter: " ++ show v ++ "."+    "Unsupported cutpoint parameter: " ++ show v ++ "."   @@ -2213,6 +2344,12 @@     case testEquality (typeOfReg r) tpr of       Just Refl -> assignReg r ex       Nothing -> reportError $ fromString $ "type mismatch when assigning undef value"+doAssign (Some r) (PoisonExpr tp) = do+  let ?err = fail+  poisonExpand (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 poison value" doAssign (Some r) (VecExpr tp vs) = do   let ?err = fail   llvmTypeAsRepr tp $ \tpr ->
src/Lang/Crucible/LLVM/Translation/Monad.hs view
@@ -48,7 +48,6 @@   , 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(..))@@ -57,6 +56,8 @@ import qualified Data.Map.Strict as Map import Data.Set (Set) import Data.Text (Text)+import Lens.Micro (Lens', lens, (^.))+import Lens.Micro.Mtl (use)  import qualified Text.LLVM.AST as L @@ -97,7 +98,7 @@    , llvmFunctionAliases :: Map L.Symbol (Set L.GlobalAlias)    } -llvmTypeCtx :: Simple Lens (LLVMContext arch) TypeContext+llvmTypeCtx :: Lens' (LLVMContext arch) TypeContext llvmTypeCtx = lens _llvmTypeCtx (\s v -> s{ _llvmTypeCtx = v })  mkLLVMContext :: GlobalVar Mem@@ -258,11 +259,11 @@   case ctx0 of     ctx' Ctx.:> ctp' ->       case testEquality ctp ctp' of-        Nothing -> error $ unwords ["crucible type mismatch",show ctp,show ctp']+        Nothing -> panic "packBase" ["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!"+    _ -> panic "packBase" ["ran out of actual arguments"]
src/Lang/Crucible/LLVM/TypeContext.hs view
@@ -38,19 +38,21 @@   , asMemType   ) where -import           Control.Lens import           Control.Monad import           Control.Monad.Except (MonadError(..)) import           Control.Monad.State (State, runState, modify, gets)+import           Data.IntMap (IntMap) 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           Lens.Micro ((^.))+import           Lens.Micro.Extras (view)+import           Lens.Micro.GHC (at)+import           Prettyprinter 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@@ -73,7 +75,7 @@       -> Map Ident IdentStatus       -> TC a       -> ([Doc ann], a)-runTC pdl initMap m = over _1 tcsErrors . view swapped $ runState m tcs0+runTC pdl initMap m = let (a, s) = runState m tcs0 in (tcsErrors s, a)   where tcs0 = TCS { tcsDataLayout = pdl                    , tcsMap =  initMap                    , tcsUnsupported = Set.empty@@ -193,8 +195,8 @@     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)+lookupMetadata :: (?lc :: TypeContext) => L.UnnamedMdIdx -> Maybe L.ValMd+lookupMetadata x = view (at (L.unnamedMdIdx x)) (llvmMetadataMap ?lc)  -- | If argument corresponds to a @MemType@ possibly via aliases, -- then return it.  Otherwise, returns @Nothing@.@@ -283,4 +285,4 @@ 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)+  all (uncurry compatMemTypes) (V.zip x y)
test/MemSetup.hs view
@@ -9,13 +9,14 @@ module MemSetup   (     withInitializedMemory+  , withTranslatedModule   )   where -import           Control.Lens ( (^.) ) import           Data.Parameterized.NatRepr import           Data.Parameterized.Nonce import           Data.Parameterized.Some+import           Lens.Micro ((^.)) import qualified Text.LLVM.AST as L  import qualified What4.Expr as WE@@ -45,24 +46,26 @@                           -> IO a)                       -> IO a withInitializedMemory mod' action =-  withLLVMCtx mod' $ \(ctx :: LLVMTr.LLVMContext arch) sym ->+  withTranslatedModule 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 =+-- | Translate an LLVM module and provide the translation, context, handle allocator, and backend.+withTranslatedModule :: 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.ModuleTranslation arch+                         -> LLVMTr.LLVMContext arch+                         -> HandleAllocator+                         -> bak+                         -> IO a)+                     -> IO a+withTranslatedModule 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@@ -80,7 +83,7 @@           let ?ptrWidth = width           let ?lc = LLVMTr._llvmTypeCtx ctx           let ?recordLLVMAnnotation = \_ _ _ -> pure ()-          action ctx bak+          action mtrans ctx halloc bak         }}}   in withIONonceGenerator $ \nonceGen ->      withHandleAllocator  $ \halloc   -> with nonceGen halloc
+ test/TestBehavior.hs view
@@ -0,0 +1,266 @@+-- | See @test/behavior/README.md@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module TestBehavior (behaviorTests) where++import           Control.Monad ( void, when, unless )+import qualified Data.ByteString.Char8 as BS+import qualified Data.List as List+import           Data.Parameterized.Context ( pattern Empty, pattern (:>) )+import qualified Data.Parameterized.Map as MapF+import qualified Data.Text as Text+import qualified Data.Text.IO as TextIO+import           Data.Time.Clock ( NominalDiffTime )+import qualified Data.Vector as V+import           Lens.Micro ((^.))+import qualified Oughta+import           System.Directory ( listDirectory )+import           System.Exit ( ExitCode(..) )+import           System.FilePath ( (-<.>), takeFileName, takeExtension, (</>) )+import qualified System.IO as IO+import qualified System.Process as Proc++import qualified Test.Tasty as T+import           Test.Tasty.HUnit ( testCase, (@=?) )++-- LLVM parsing+import qualified Text.LLVM.AST as L+import           Data.LLVM.BitCode ( parseBitCodeFromFileWithWarnings )++-- Crucible+import           Lang.Crucible.Backend ( backendGetSym, getProofObligations )+import qualified Lang.Crucible.Backend as CB+import qualified Lang.Crucible.Simulator as CS+import           Lang.Crucible.Simulator ( timeoutFeature, genericToExecutionFeature )+import           Lang.Crucible.Simulator.ExecutionTree ( ExecResult(..) )+import qualified Lang.Crucible.CFG.Core as CC++-- LLVM+import           Lang.Crucible.LLVM ( registerLazyModule )+import qualified Lang.Crucible.LLVM as CL+import qualified Lang.Crucible.LLVM.Globals as LLVMG+import qualified Lang.Crucible.LLVM.Intrinsics as Intrinsics+import qualified Lang.Crucible.LLVM.MemModel as LLVMMem+import qualified Lang.Crucible.LLVM.SymIO as SymIO+import qualified Lang.Crucible.LLVM.Translation as Trans+import           What4.Interface ( bvOne )++-- Reuse from existing tests+import           MemSetup ( withTranslatedModule )+++behaviorTests :: IO T.TestTree+behaviorTests = do+  let behaviorDir = "test/behavior"+  files <- listDirectory behaviorDir+  let cFiles = List.sort $ filter (\f -> takeExtension f == ".c") files+  let testTrees = map (\f -> testBehaviorFile (behaviorDir </> f)) cFiles++  let gccDir = "test/behavior/gcc-c-torture"+  extFiles <- listDirectory gccDir+  let cExtFiles = List.sort $ filter (\f -> takeExtension f == ".c") extFiles+  let gccTests = map (\f -> testBehaviorFileExternal (gccDir </> f)) cExtFiles++  return $ T.testGroup "Behavior tests"+    [ T.testGroup "Manual tests" testTrees+    , T.testGroup "GCC tests" gccTests+    ]+++testBehaviorFile :: FilePath -> T.TestTree+testBehaviorFile cFile = testCase (takeFileName cFile) $ do+  (outputLuaProg, llvmLuaProg) <- extractLuaProgs cFile++  exePath <- compileExe cFile+  bcPath <- cimpileBc cFile++  nativeOut <- runExe exePath+  symbolicOut <- runBc bcPath++  nativeOut @=? symbolicOut+  Oughta.check' Oughta.defaultHooks outputLuaProg (Oughta.Output $ BS.pack nativeOut)++  llPath <- compileLl cFile+  llvmIr <- BS.readFile llPath+  Oughta.check' Oughta.defaultHooks llvmLuaProg (Oughta.Output llvmIr)+++-- | Test external test files that don't have expected output comments+-- Just verify that both native and symbolic execution succeed+-- These tests use abort() on failure rather than output checks+testBehaviorFileExternal :: FilePath -> T.TestTree+testBehaviorFileExternal cFile = testCase (takeFileName cFile) $ do+  exePath <- compileExe cFile+  bcPath <- cimpileBc cFile+  nativeOut <- runExe exePath+  symbolicOut <- runBc bcPath+  nativeOut @=? symbolicOut++cflags :: [String]+cflags = ["-O1", "-Wno-implicit-function-declaration", "-Wno-implicit-int"]++compileFile :: String -> FilePath -> [String] -> IO FilePath+compileFile outputExt cFile additionalArgs = do+  let outPath = cFile -<.> outputExt+  let args = cflags ++ additionalArgs ++ ["-o", outPath, cFile]+  (exitCode, stdout, stderr) <- Proc.readProcessWithExitCode "clang" args ""+  when (exitCode /= ExitSuccess) $+    fail $ unlines $+      [ "Compilation failed!"+      , "clang " ++ unwords args+      , "stdout:"+      , stdout+      , "stderr:"+      , stderr+      ]+  return outPath++compileExe :: FilePath -> IO FilePath+compileExe cFile =+  compileFile ".exe" cFile ["-fsanitize=undefined"]++cimpileBc :: FilePath -> IO FilePath+cimpileBc cFile =+  compileFile ".bc" cFile ["-emit-llvm", "-fno-discard-value-names", "-c"]++compileLl :: FilePath -> IO FilePath+compileLl cFile =+  compileFile ".ll" cFile ["-emit-llvm", "-fno-discard-value-names", "-S"]++runExe :: FilePath -> IO String+runExe exePath = do+  (exitCode, stdout, stderr) <- Proc.readProcessWithExitCode exePath [] ""+  when (exitCode /= ExitSuccess) $+    fail $ unlines $+      [ "Native execution failed!"+      , exePath+      , "stdout:"+      , stdout+      , "stderr:"+      , stderr+      ]+  return stdout++-- | @(outputLuaProg, llvmLuaProg)@+extractLuaProgs :: FilePath -> IO (Oughta.LuaProgram, Oughta.LuaProgram)+extractLuaProgs cFile = do+  content <- TextIO.readFile cFile+  let contentLines = lines (Text.unpack content)+      hasOutputChecks = any ("/// " `List.isInfixOf`) contentLines+      hasLlvmChecks = any ("//- " `List.isInfixOf`) contentLines++  unless hasOutputChecks $+    fail $ "Test file " ++ cFile ++ " must have output checks (/// comments)"+  unless hasLlvmChecks $+    fail $ "Test file " ++ cFile ++ " must have LLVM IR checks (//- comments)"++  let outputLuaProg = Oughta.fromLineComments cFile "/// " content+      llvmLuaProg = Oughta.fromLineComments cFile "//- " content++  return (outputLuaProg, llvmLuaProg)+++ppAbortedResult :: CS.AbortedResult sym ext -> String+ppAbortedResult ar = case ar of+  CS.AbortedExec reason _ -> show (CB.ppAbortExecReason reason)+  CS.AbortedExit code _ -> "exit " ++ show code+  CS.AbortedBranch _ _ res1 res2 ->+    unlines+    [ "branch:"+    , ppAbortedResult res1+    , ppAbortedResult res2+    ]++parseBc :: FilePath -> IO L.Module+parseBc file =+  parseBitCodeFromFileWithWarnings file >>= \case+    Left err -> fail $ "Couldn't parse LLVM bitcode from file " ++ file ++ "\n" ++ show err+    Right (m, _warnings) -> return m+++-- | Symbolically execute an LLVM bitcode file and capture stdout+runBc :: FilePath -> IO String+runBc bcPath = do+  llvmMod <- parseBc bcPath++  let outPath = bcPath -<.> ".out"+  outHandle <- IO.openFile outPath IO.WriteMode+  IO.hSetBuffering outHandle IO.LineBuffering++  withTranslatedModule @() llvmMod $ \trans ctx halloc bak -> do+    let memVar = Trans.llvmMemVar ctx++    CC.AnyCFG mainCfg <-+      Trans.getTranslatedCFG trans "main" >>=+        \case+          Nothing -> fail "Could not find 'main' function in module"+          Just (_, cfg, _warns) -> return cfg++    mem <- LLVMG.initializeAllMemory bak ctx llvmMod+    mem' <- LLVMG.populateAllGlobals bak (trans ^. Trans.globalInitMap) mem++    let intrinsicTypes = MapF.union Intrinsics.llvmIntrinsicTypes SymIO.llvmSymIOIntrinsicTypes+    let fns = CS.fnBindingsFromList []+    let impl = CL.llvmExtensionImpl ?memOpts+    let simCtx = CS.initSimContext bak intrinsicTypes halloc outHandle fns impl ()++    mainArgs <-+      case CC.cfgArgTypes mainCfg of+        -- main(int argc, char** argv)+        (Empty :> LLVMMem.LLVMPointerRepr w :> LLVMMem.PtrRepr) -> do+          let sym = backendGetSym bak+          argc_ <- LLVMMem.llvmPointer_bv sym =<< bvOne sym w+          argv_ <- LLVMMem.mkNullPointer sym LLVMMem.PtrWidth+          let argc = CS.RegEntry (LLVMMem.LLVMPointerRepr w) argc_+          let argv = CS.RegEntry LLVMMem.PtrRepr argv_+          return (CS.RegMap (Empty :> argc :> argv))++        -- main(void)+        Empty -> return CS.emptyRegMap++        -- main() - technically varargs+        (Empty :> CC.VectorRepr elemTy) -> do+          let v = CS.RegEntry (CC.VectorRepr elemTy) V.empty+          return (CS.RegMap (Empty :> v))++        _ -> fail "Unsupported main function signature"++    let ?intrinsicsOpts = Intrinsics.defaultIntrinsicsOptions+    let retType = CC.cfgReturnType mainCfg+    let globSt = CL.llvmGlobals memVar mem'+    let simSt = CS.InitialState simCtx globSt CS.defaultAbortHandler retType $+                  CS.runOverrideSim retType $ do+                    void $ Intrinsics.register_llvm_overrides llvmMod [] [] ctx+                    registerLazyModule (\_ -> return ()) trans+                    CS.regValue <$> CS.callCFG mainCfg mainArgs++    timeoutFeat <- timeoutFeature (5 :: NominalDiffTime)+    let features = [genericToExecutionFeature timeoutFeat]++    execResult <- CS.executeCrucible features simSt+    case execResult of+      FinishedResult {} -> do+        obligations <- getProofObligations bak+        case obligations of+          Nothing -> return ()+          Just _ -> fail "Symbolic execution finished with pending proof obligations"+      AbortedResult _ abortResult -> do+        case abortResult of+          CS.AbortedExit ExitSuccess _ -> return ()+          CS.AbortedExec (CB.EarlyExit _) _ -> return ()  -- exit()+          _ -> fail (ppAbortedResult abortResult)+      TimeoutResult {} -> fail "Symbolic execution timed out"++  IO.hFlush outHandle+  IO.hClose outHandle+  readFile outPath
test/TestFunctions.hs view
@@ -60,7 +60,8 @@                           (L.PtrTo                             (L.Alias (L.Ident "class.std::cls"))) Nothing (Just 8))                         []-                      , L.Effect L.RetVoid []+                        []+                      , L.Effect L.RetVoid [] []                       ]                   }                 ]
test/TestMemory.hs view
@@ -13,10 +13,10 @@   ) where -import           Control.Lens ( (^.), _1, _2 ) import           Control.Monad ( foldM, forM_, void ) import           Data.Foldable ( foldlM ) import qualified Data.Vector as V+import           Lens.Micro ((^.), _1, _2)  import qualified Test.Tasty as T import           Test.Tasty.HUnit ( testCase, (@=?), assertFailure )@@ -592,8 +592,8 @@                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)+           checkField bak struct_bv1 (struct_val' ^. _1)+           checkField bak struct_bv2 (struct_val' ^. _2)       testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = False })      testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = True
test/Tests.hs view
@@ -9,12 +9,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Main where+module Main (main) where  -- Crucible import           Lang.Crucible.FunctionHandle ( newHandleAllocator )  import qualified Data.BitVector.Sized as BV+import           Data.Parameterized.DecidableEq ( decEq ) import           Data.Parameterized.Some import           Data.Parameterized.NatRepr import           Data.Parameterized.SymbolRepr ( SomeSym(SomeSym) )@@ -32,13 +33,15 @@ 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           Data.Functor.Classes ( Eq1(liftEq) )+import           Data.Functor.Identity ( Identity(..) ) import qualified Data.Map.Strict as Map+import           Data.Maybe ( catMaybes ) import           Data.Proxy ( Proxy(..) )+import           GHC.TypeLits+import           Lens.Micro.Extras (view) import qualified System.Directory as Dir import           System.Environment ( lookupEnv ) import           System.Exit ( ExitCode(..) )@@ -46,11 +49,16 @@ import qualified System.IO as IO import qualified System.Process as Proc ++import qualified What4.Internal as WInt+ -- Modules being tested+import           Lang.Crucible.LLVM.Internal (assertionsEnabled) import           Lang.Crucible.LLVM.MemModel ( mkMemVar ) import           Lang.Crucible.LLVM.MemType import           Lang.Crucible.LLVM.Translation +import           TestBehavior (behaviorTests) import           TestFunctions import           TestGlobals import           TestMemory@@ -155,9 +163,20 @@                testBuildTranslation (TS.rootFile sweets) $                (\getTrans -> testGroup "checks" $ map (transCheck getTrans) checklist) +       behaviorTestTree <- behaviorTests+        defaultMainWithIngredients llvmTestIngredients $          testGroup "Tests"-         [ functionTests+         [ -- See Note [Asserts] in crucible-llvm+           testCase "assertions enabled" $ do+             assertsEnabled <- assertionsEnabled+             assertBool "assertions should be enabled" assertsEnabled+         , -- See Note [Asserts] in what4+           testCase "What4 assertions enabled" $ do+             assertsEnabled <- WInt.assertionsEnabled+             assertBool "What4 assertions should be enabled" assertsEnabled+         , behaviorTestTree+         , functionTests          , globalTests          , memoryTests          , translationTests@@ -252,31 +271,133 @@   "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)+    case snd <$> Map.lookup (L.Symbol "extern_int") (view globalInitMap t) of+      Just (Right (actualTy, actualMbConst)) -> do+        let expectedTy = i32+        let expectedMbConst = Nothing+        expectedTy @=? actualTy+        assertLiftEq llvmConstSyntacticEq expectedMbConst actualMbConst+      _ -> assertFailure "Could not look up extern_int"    "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)+    case snd <$> Map.lookup (L.Symbol "x") (view globalInitMap t) of+      Just (Right (actualTy, actualMbConst)) -> do+        let expectedTy = i32+        let expectedMbConst = Just $ IntConst (knownNat @32) (BV.mkBV knownNat 42)+        expectedTy @=? actualTy+        assertLiftEq llvmConstSyntacticEq expectedMbConst actualMbConst+      _ -> assertFailure "Could not look up x"    "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)+    case snd <$> Map.lookup (L.Symbol "z") (view globalInitMap t) of+      Just (Right (_, actualMbConst)) ->+        case actualMbConst of+          Just (StructConst _ (actualXField : _)) -> do+            let expectedXField = IntConst (knownNat @32) (BV.mkBV knownNat 17)+            assertLiftEq+              llvmConstSyntacticEq+              (Identity expectedXField)+              (Identity actualXField)+          _ -> assertFailure $+            "Expected x to be a struct with at least one field, " +++            "but it was actually " ++ show actualMbConst+      _ -> assertFailure "Could not look up z"    "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)+    case snd <$> Map.lookup (L.Symbol "x") (view globalInitMap t) of+      Just (Right (actualTy, actualMbConst)) -> do+        let expectedTy = i32+        let expectedMbConst = Just $ ZeroConst i32+        expectedTy @=? actualTy+        assertLiftEq llvmConstSyntacticEq expectedMbConst actualMbConst+      _ -> assertFailure "Could not look up x"    -- We're really just checking that the translation succeeds without   -- exceptions.   "" -> testCase "no additional checks" $ return ()    other -> testCase other $ assertFailure $ "Unknown check: " <> other++-- | Helper, not exported+--+-- Compare two 'LLVMConst's for syntactic equality. This should not be confused+-- with the semantic notion of equality that LLVM typically uses. For instance,+-- this function considers two 'UndefConst's values to be syntactically equal,+-- but LLVM's semantic equality could deem two @undef@ values to be not equal.+llvmConstSyntacticEq :: LLVMConst -> LLVMConst -> Bool+llvmConstSyntacticEq (ZeroConst mem1) (ZeroConst mem2) =+  mem1 == mem2+llvmConstSyntacticEq (IntConst w1 x1) (IntConst w2 x2) =+  case decEq w1 w2 of+    Left Refl -> x1 == x2+    Right _   -> False+llvmConstSyntacticEq (FloatConst f1) (FloatConst f2) =+  f1 == f2+llvmConstSyntacticEq (DoubleConst d1) (DoubleConst d2) =+  d1 == d2+llvmConstSyntacticEq (LongDoubleConst ld1) (LongDoubleConst ld2) =+  ld1 == ld2+llvmConstSyntacticEq (StringConst s1) (StringConst s2) =+  s1 == s2+llvmConstSyntacticEq (ArrayConst mem1 a1) (ArrayConst mem2 a2) =+  mem1 == mem2 && liftEq llvmConstSyntacticEq a1 a2+llvmConstSyntacticEq (VectorConst mem1 v1) (VectorConst mem2 v2) =+  mem1 == mem2 && liftEq llvmConstSyntacticEq v1 v2+llvmConstSyntacticEq (StructConst si1 a1) (StructConst si2 a2) =+  si1 == si2 && liftEq llvmConstSyntacticEq a1 a2+llvmConstSyntacticEq (SymbolConst s1 x1) (SymbolConst s2 x2) =+  s1 == s2 && x1 == x2+llvmConstSyntacticEq (UndefConst tp1) (UndefConst tp2) =+  tp1 == tp2+llvmConstSyntacticEq (PoisonConst tp1) (PoisonConst tp2) =+  tp1 == tp2++llvmConstSyntacticEq (ZeroConst {}) _ =+  False+llvmConstSyntacticEq (IntConst {}) _ =+  False+llvmConstSyntacticEq (FloatConst {}) _ =+  False+llvmConstSyntacticEq (DoubleConst {}) _ =+  False+llvmConstSyntacticEq (LongDoubleConst {}) _ =+  False+llvmConstSyntacticEq (StringConst {}) _ =+  False+llvmConstSyntacticEq (ArrayConst {}) _ =+  False+llvmConstSyntacticEq (VectorConst {}) _ =+  False+llvmConstSyntacticEq (StructConst {}) _ =+  False+llvmConstSyntacticEq (SymbolConst {}) _ =+  False+llvmConstSyntacticEq (UndefConst {}) _ =+  False+llvmConstSyntacticEq (PoisonConst {}) _ =+  False++-- | Helper, not exported+--+-- Like 'assertEqual', but lifted to work over an 'Eq1' instance instead of an+-- 'Eq' instance. In addition, this allows the user to customize how to check+-- the underlying values (of type @expected@ and @actual@) for equality.+assertLiftEq ::+  (Eq1 f, Show (f expected), Show (f actual), HasCallStack) =>+  -- | How to check the underlying values for equality+  (expected -> actual -> Bool) ->+  -- | The expected value+  f expected ->+  -- | The actual value+  f actual ->+  Assertion+assertLiftEq eq expected actual =+  unless (liftEq eq expected actual) (assertFailure msg)+  where+    msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual