diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/crucible-llvm.cabal b/crucible-llvm.cabal --- a/crucible-llvm.cabal +++ b/crucible-llvm.cabal @@ -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, diff --git a/src/Lang/Crucible/LLVM.hs b/src/Lang/Crucible/LLVM.hs --- a/src/Lang/Crucible/LLVM.hs +++ b/src/Lang/Crucible/LLVM.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Arch/X86.hs b/src/Lang/Crucible/LLVM/Arch/X86.hs --- a/src/Lang/Crucible/LLVM/Arch/X86.hs +++ b/src/Lang/Crucible/LLVM/Arch/X86.hs @@ -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 = diff --git a/src/Lang/Crucible/LLVM/ArraySizeProfile.hs b/src/Lang/Crucible/LLVM/ArraySizeProfile.hs --- a/src/Lang/Crucible/LLVM/ArraySizeProfile.hs +++ b/src/Lang/Crucible/LLVM/ArraySizeProfile.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/DataLayout.hs b/src/Lang/Crucible/LLVM/DataLayout.hs --- a/src/Lang/Crucible/LLVM/DataLayout.hs +++ b/src/Lang/Crucible/LLVM/DataLayout.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Errors.hs b/src/Lang/Crucible/LLVM/Errors.hs --- a/src/Lang/Crucible/LLVM/Errors.hs +++ b/src/Lang/Crucible/LLVM/Errors.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Errors/MemoryError.hs b/src/Lang/Crucible/LLVM/Errors/MemoryError.hs --- a/src/Lang/Crucible/LLVM/Errors/MemoryError.hs +++ b/src/Lang/Crucible/LLVM/Errors/MemoryError.hs @@ -6,6 +6,7 @@ -- Maintainer : Langston Barrett -- 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 diff --git a/src/Lang/Crucible/LLVM/Errors/Poison.hs b/src/Lang/Crucible/LLVM/Errors/Poison.hs --- a/src/Lang/Crucible/LLVM/Errors/Poison.hs +++ b/src/Lang/Crucible/LLVM/Errors/Poison.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Errors/Standards.hs b/src/Lang/Crucible/LLVM/Errors/Standards.hs --- a/src/Lang/Crucible/LLVM/Errors/Standards.hs +++ b/src/Lang/Crucible/LLVM/Errors/Standards.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs b/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs --- a/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs +++ b/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Eval.hs b/src/Lang/Crucible/LLVM/Eval.hs --- a/src/Lang/Crucible/LLVM/Eval.hs +++ b/src/Lang/Crucible/LLVM/Eval.hs @@ -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 + ] diff --git a/src/Lang/Crucible/LLVM/Extension/Syntax.hs b/src/Lang/Crucible/LLVM/Extension/Syntax.hs --- a/src/Lang/Crucible/LLVM/Extension/Syntax.hs +++ b/src/Lang/Crucible/LLVM/Extension/Syntax.hs @@ -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 - -- - -- - 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 - -- - -- - 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 - -- - -- - 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|] []) diff --git a/src/Lang/Crucible/LLVM/Functions.hs b/src/Lang/Crucible/LLVM/Functions.hs --- a/src/Lang/Crucible/LLVM/Functions.hs +++ b/src/Lang/Crucible/LLVM/Functions.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Globals.hs b/src/Lang/Crucible/LLVM/Globals.hs --- a/src/Lang/Crucible/LLVM/Globals.hs +++ b/src/Lang/Crucible/LLVM/Globals.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Internal.hs b/src/Lang/Crucible/LLVM/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Internal.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Intrinsics.hs b/src/Lang/Crucible/LLVM/Intrinsics.hs --- a/src/Lang/Crucible/LLVM/Intrinsics.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics.hs @@ -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 ] diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs b/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs @@ -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 -- 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) + } diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Common.hs b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Common.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs @@ -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 -- 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) diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Declare.hs b/src/Lang/Crucible/LLVM/Intrinsics/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Declare.hs @@ -0,0 +1,110 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Declare +-- Description : Function declarations +-- Copyright : (c) Galois, Inc 2026 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- 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) diff --git a/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs @@ -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 = " " ++ 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 = " " ++ 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 = " " ++ 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 + + +---------------------------------------------------------------------------- + diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc/Math.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Math.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Math.hs @@ -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. +-- 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 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdio.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdio.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdio.hs @@ -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. +-- 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]) + } diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdlib.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdlib.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc/Stdlib.hs @@ -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. +-- 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 = " " ++ 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 = " " ++ 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 = " " ++ 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 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc/String.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc/String.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc/String.hs @@ -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. +-- 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' = " " ++ 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' = " " ++ 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 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs @@ -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) diff --git a/src/Lang/Crucible/LLVM/MemModel.hs b/src/Lang/Crucible/LLVM/MemModel.hs --- a/src/Lang/Crucible/LLVM/MemModel.hs +++ b/src/Lang/Crucible/LLVM/MemModel.hs @@ -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 "" 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 diff --git a/src/Lang/Crucible/LLVM/MemModel/Common.hs b/src/Lang/Crucible/LLVM/MemModel/Common.hs --- a/src/Lang/Crucible/LLVM/MemModel/Common.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Common.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/MemModel/Generic.hs b/src/Lang/Crucible/LLVM/MemModel/Generic.hs --- a/src/Lang/Crucible/LLVM/MemModel/Generic.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Generic.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/MemModel/MemLog.hs b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs --- a/src/Lang/Crucible/LLVM/MemModel/MemLog.hs +++ b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs @@ -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 :: diff --git a/src/Lang/Crucible/LLVM/MemModel/Partial.hs b/src/Lang/Crucible/LLVM/MemModel/Partial.hs --- a/src/Lang/Crucible/LLVM/MemModel/Partial.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Partial.hs @@ -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 = diff --git a/src/Lang/Crucible/LLVM/MemModel/Pointer.hs b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs --- a/src/Lang/Crucible/LLVM/MemModel/Pointer.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs @@ -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. -- diff --git a/src/Lang/Crucible/LLVM/MemModel/Strings.hs b/src/Lang/Crucible/LLVM/MemModel/Strings.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Strings.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/MemModel/Type.hs b/src/Lang/Crucible/LLVM/MemModel/Type.hs --- a/src/Lang/Crucible/LLVM/MemModel/Type.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Type.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/MemModel/Value.hs b/src/Lang/Crucible/LLVM/MemModel/Value.hs --- a/src/Lang/Crucible/LLVM/MemModel/Value.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Value.hs @@ -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 " viaShow tp <> pretty ">" + LLVMValPoison tp -> pretty " 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) = "" + show (LLVMValPoison tp) = "" show (LLVMValString _) = "" show (LLVMValInt blk w) | Just 0 <- asNat blk = "" @@ -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) diff --git a/src/Lang/Crucible/LLVM/MemType.hs b/src/Lang/Crucible/LLVM/MemType.hs --- a/src/Lang/Crucible/LLVM/MemType.hs +++ b/src/Lang/Crucible/LLVM/MemType.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/QQ.hs b/src/Lang/Crucible/LLVM/QQ.hs --- a/src/Lang/Crucible/LLVM/QQ.hs +++ b/src/Lang/Crucible/LLVM/QQ.hs @@ -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, diff --git a/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs b/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs --- a/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs +++ b/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs b/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs --- a/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs +++ b/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs --- a/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs +++ b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs @@ -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 :: diff --git a/src/Lang/Crucible/LLVM/SymIO.hs b/src/Lang/Crucible/LLVM/SymIO.hs --- a/src/Lang/Crucible/LLVM/SymIO.hs +++ b/src/Lang/Crucible/LLVM/SymIO.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Translation.hs b/src/Lang/Crucible/LLVM/Translation.hs --- a/src/Lang/Crucible/LLVM/Translation.hs +++ b/src/Lang/Crucible/LLVM/Translation.hs @@ -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 diff --git a/src/Lang/Crucible/LLVM/Translation/Aliases.hs b/src/Lang/Crucible/LLVM/Translation/Aliases.hs --- a/src/Lang/Crucible/LLVM/Translation/Aliases.hs +++ b/src/Lang/Crucible/LLVM/Translation/Aliases.hs @@ -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? diff --git a/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs b/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs --- a/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs +++ b/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs @@ -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) diff --git a/src/Lang/Crucible/LLVM/Translation/Constant.hs b/src/Lang/Crucible/LLVM/Translation/Constant.hs --- a/src/Lang/Crucible/LLVM/Translation/Constant.hs +++ b/src/Lang/Crucible/LLVM/Translation/Constant.hs @@ -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 +-- .) -- -- * @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__" diff --git a/src/Lang/Crucible/LLVM/Translation/Expr.hs b/src/Lang/Crucible/LLVM/Translation/Expr.hs --- a/src/Lang/Crucible/LLVM/Translation/Expr.hs +++ b/src/Lang/Crucible/LLVM/Translation/Expr.hs @@ -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) = "" show (UndefExpr mt) = "" + show (PoisonExpr 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 diff --git a/src/Lang/Crucible/LLVM/Translation/Instruction.hs b/src/Lang/Crucible/LLVM/Translation/Instruction.hs --- a/src/Lang/Crucible/LLVM/Translation/Instruction.hs +++ b/src/Lang/Crucible/LLVM/Translation/Instruction.hs @@ -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 -> diff --git a/src/Lang/Crucible/LLVM/Translation/Monad.hs b/src/Lang/Crucible/LLVM/Translation/Monad.hs --- a/src/Lang/Crucible/LLVM/Translation/Monad.hs +++ b/src/Lang/Crucible/LLVM/Translation/Monad.hs @@ -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"] diff --git a/src/Lang/Crucible/LLVM/TypeContext.hs b/src/Lang/Crucible/LLVM/TypeContext.hs --- a/src/Lang/Crucible/LLVM/TypeContext.hs +++ b/src/Lang/Crucible/LLVM/TypeContext.hs @@ -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) diff --git a/test/MemSetup.hs b/test/MemSetup.hs --- a/test/MemSetup.hs +++ b/test/MemSetup.hs @@ -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 diff --git a/test/TestBehavior.hs b/test/TestBehavior.hs new file mode 100644 --- /dev/null +++ b/test/TestBehavior.hs @@ -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 diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs --- a/test/TestFunctions.hs +++ b/test/TestFunctions.hs @@ -60,7 +60,8 @@ (L.PtrTo (L.Alias (L.Ident "class.std::cls"))) Nothing (Just 8)) [] - , L.Effect L.RetVoid [] + [] + , L.Effect L.RetVoid [] [] ] } ] diff --git a/test/TestMemory.hs b/test/TestMemory.hs --- a/test/TestMemory.hs +++ b/test/TestMemory.hs @@ -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 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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