diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,67 @@ +# 0.6 -- 2024-02-05 + +* `bindLLVMFunPtr` now accepts an `Text.LLVM.AST.Symbol` rather than a whole `Declare`. + Use `decName` to get a `Symbol` from a `Declare`. +* Implement overrides for the LLVM `llvm.is.fpclass.f*` intrinsics. +* Implement overrides for the `isinf`, `__isinf`, and `__isinff` C functions. +* Implement overrides for the LLVM `llvm.fma.f*` and `llvm.fmuladd.f*` + intrinsics. +* Implement overrides for the `fma` and `fmaf` C functions. +* Add a `Lang.Crucible.LLVM.MemModel.CallStack.null` function. +* Add a `ppLLVMLatest` function to `Lang.Crucible.LLVM.PrettyPrint`, which + pretty-prints an LLVM AST using the latest LLVM version that `llvm-pretty` + currently supports. Also add derived combinators (`ppDeclare`, `ppIdent`, + etc.) for calling the `llvm-pretty` functions of the same names in tandem + with `ppLLVMLatest`. + +# 0.5 +* Add `?memOpts :: MemOptions` constraints to the following functions: + * `Lang.Crucible.LLVM.MemModel`: `doStore`, `storeRaw`, `condStoreRaw`, and + `storeConstRaw` + * `Lang.Crucible.LLVM.Globals`: `populateGlobal` + * `Lang.Crucible.LLVM.MemModel.Generic`: `writeMem` and `writeConstMem` +* `Lang.Crucible.LLVM`: `registerModuleFn` has changed type to + accomodate lazy loading of Crucible IR. +* `Lang.Crucible.LLVM.Translation` : The `ModuleTranslation` record is + now opaque, the `cfgMap` is no longer exported and `globalInitMap` + and `modTransNonce` have become lens-style getters instead of record + accessors. CFGs should be retrieved using the new `getTranslatedCFG` + or `getTranslatedCFGForHandle` functions. +* `Lang.Crucible.LLVM` : new functions `registerLazyModuleFn` and + `registerLazyModule`, which delay the building of Crucible CFGs until + the functions in question are actually called. +* `executeDirectives` in `Lang.Crucible.LLVM.Printf` now returns a `ByteString` + instead of a `String` so that we can better preserve the exact bytes used in + string arguments, without applying a particular text encoding. +* `crucible-llvm` now handles LLVM's opaque pointer types, an alternative + representation of pointer types that does not store a pointee type. As a + result, `MemType` now has an additional `PtrOpaqueType` constructor in + addition to the existing (non-opaque) `PtrType` constructor. + + LLVM 15 and later use opaque pointers by default, so it is recommended that + you add support for `PtrOpaqueType` (and opaque pointers in general) going + forward. `crucible-llvm` still supports both kinds of pointers, so you can + fall back to non-opaque pointers if need be. +* A new `Lang.Crucible.LLVM.SimpleLoopInvariant` module has been added, which + provides an execution feature that facilitates reasoning about certain kinds + of loops (which may not terminate) using loop invariants. Note that this + functionality is very experimental and subject to change in the future. + +# 0.4 +* A new `indeterminateLoadBehavior` flag in `MemOptions` now controls now + reading from uninitialized memory works when `laxLoadsAndStores` is enabled. + If `StableSymbolic` is chosen, then allocating memory will also initialize it + with a fresh symbolic value so that subsequent reads will always return that + same value. If `UnstableSymbolic` is chosen, then each read from a section of + uninitialized memory will return a distinct symbolic value each time. + + As a result of this change, `?memOpts :: MemOptions` constraints have been + added to the following functions: + * `Lang.Crucible.LLVM.Globals`: + `initializeAllMemory`, `initializeMemoryConstGlobals`, `populateGlobals`, + `populateAllGlobals`, and `populateConstGlobals` + * `Lang.Crucible.LLVM.MemModel`: + `doAlloca`, `doCalloc`, `doInvalidate`, `doMalloc`, `doMallocUnbounded`, + `mallocRaw`, `mallocConstRaw`, `allocGlobals`, and `allocGlobal` +* `HasLLVMAnn` now has an additional `CallStack` argument, which is used for + annotating errors with call stacks. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2022 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +This package implements an LLVM frontend for Crucible. The frontend provides two major things: +1. A translation of LLVM IR into the Crucible IR +2. Data types supporting that translation + +Most clients of the library that just want to analyze LLVM IR (which usually means C and C++) will only need the `Lang.Crucible.LLVM` and `Lang.Crucible.LLVM.Translation` modules. The core data structure implementing the LLVM memory model (see `Lang.Crucible.LLVM.MemModel`) may be of interest to other clients. The memory model is documented in more detail in [the docs](doc/memory-model.md). diff --git a/crucible-llvm.cabal b/crucible-llvm.cabal new file mode 100644 --- /dev/null +++ b/crucible-llvm.cabal @@ -0,0 +1,150 @@ +Cabal-version: 2.2 +Name: crucible-llvm +Version: 0.6 +Author: Galois Inc. +Copyright: (c) Galois, Inc 2014-2022 +Maintainer: rscott@galois.com, kquick@galois.com, langston@galois.com +License: BSD-3-Clause +License-file: LICENSE +Build-type: Simple +Category: Language +Synopsis: Support for translating and executing LLVM code in Crucible +Description: + Library providing LLVM-specific extensions to the crucible core library + for Crucible-based simulation and verification of LLVM-compiled applications. +extra-source-files: CHANGELOG.md, README.md + +source-repository head + type: git + location: https://github.com/GaloisInc/crucible + subdir: crucible-llvm + +common bldflags + ghc-options: -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -Werror=overlapping-patterns + -Wpartial-fields + -Wincomplete-uni-patterns + ghc-prof-options: -O2 -fprof-auto-exported + default-language: Haskell2010 + + +library + import: bldflags + build-depends: + base >= 4.13 && < 4.19, + attoparsec, + bv-sized >= 1.0.0, + bytestring, + containers >= 0.5.8.0, + crucible >= 0.5, + crucible-symio, + what4 >= 0.4.1, + extra, + lens, + itanium-abi >= 0.1.1.1 && < 0.2, + llvm-pretty >= 0.12 && < 0.13, + mtl, + parameterized-utils >= 2.1.5 && < 2.2, + pretty, + prettyprinter >= 1.7.0, + text, + template-haskell, + transformers, + utf8-string, + vector + + hs-source-dirs: src + + exposed-modules: + Lang.Crucible.LLVM + Lang.Crucible.LLVM.Arch.Util + Lang.Crucible.LLVM.Arch.X86 + Lang.Crucible.LLVM.ArraySizeProfile + Lang.Crucible.LLVM.Bytes + Lang.Crucible.LLVM.Ctors + Lang.Crucible.LLVM.DataLayout + Lang.Crucible.LLVM.Errors + Lang.Crucible.LLVM.Errors.MemoryError + Lang.Crucible.LLVM.Errors.Poison + Lang.Crucible.LLVM.Errors.UndefinedBehavior + Lang.Crucible.LLVM.Eval + Lang.Crucible.LLVM.Extension + Lang.Crucible.LLVM.Globals + Lang.Crucible.LLVM.Intrinsics + Lang.Crucible.LLVM.Intrinsics.Libc + Lang.Crucible.LLVM.Intrinsics.LLVM + Lang.Crucible.LLVM.MalformedLLVMModule + Lang.Crucible.LLVM.MemModel + Lang.Crucible.LLVM.MemModel.CallStack + Lang.Crucible.LLVM.MemModel.CallStack.Internal + Lang.Crucible.LLVM.MemModel.Generic + Lang.Crucible.LLVM.MemModel.MemLog + Lang.Crucible.LLVM.MemModel.Partial + Lang.Crucible.LLVM.MemModel.Pointer + Lang.Crucible.LLVM.MemType + Lang.Crucible.LLVM.PrettyPrint + Lang.Crucible.LLVM.Printf + Lang.Crucible.LLVM.QQ + Lang.Crucible.LLVM.SymIO + Lang.Crucible.LLVM.SimpleLoopFixpoint + Lang.Crucible.LLVM.SimpleLoopInvariant + Lang.Crucible.LLVM.Translation + Lang.Crucible.LLVM.Translation.Aliases + Lang.Crucible.LLVM.TypeContext + + other-modules: + Lang.Crucible.LLVM.Errors.Standards + Lang.Crucible.LLVM.Extension.Arch + Lang.Crucible.LLVM.Extension.Syntax + Lang.Crucible.LLVM.Intrinsics.Common + Lang.Crucible.LLVM.Intrinsics.Libcxx + Lang.Crucible.LLVM.Intrinsics.Options + Lang.Crucible.LLVM.MemModel.Common + Lang.Crucible.LLVM.MemModel.Options + Lang.Crucible.LLVM.MemModel.Type + Lang.Crucible.LLVM.MemModel.Value + Lang.Crucible.LLVM.Translation.BlockInfo + Lang.Crucible.LLVM.Translation.Constant + Lang.Crucible.LLVM.Translation.Expr + Lang.Crucible.LLVM.Translation.Instruction + Lang.Crucible.LLVM.Translation.Monad + Lang.Crucible.LLVM.Translation.Options + Lang.Crucible.LLVM.Translation.Types + Lang.Crucible.LLVM.Types + Lang.Crucible.LLVM.Utils + + default-extensions: NoStarIsType + + +test-suite crucible-llvm-tests + import: bldflags + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + other-modules: MemSetup + , TestFunctions + , TestGlobals + , TestMemory + , TestTranslation + build-depends: + base, + bv-sized, + containers, + crucible, + crucible-llvm, + directory, + filepath, + lens, + llvm-pretty, + llvm-pretty-bc-parser, + lens, + parameterized-utils, + process, + what4, + tasty, + tasty-quickcheck, + tasty-hunit, + tasty-sugar >= 2.0 && < 2.3, + vector diff --git a/src/Lang/Crucible/LLVM.hs b/src/Lang/Crucible/LLVM.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM +-- Description : LLVM interface for Crucible +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : rdockins@galois.com +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM + ( LLVM + , registerModule + , registerModuleFn + , registerLazyModule + , registerLazyModuleFn + , llvmGlobalsToCtx + , llvmGlobals + , register_llvm_overrides + , llvmExtensionImpl + ) where + +import Control.Lens +import Control.Monad (when) +import Control.Monad.IO.Class +import qualified Text.LLVM.AST as L + +import Lang.Crucible.Analysis.Postdom +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Core +import Lang.Crucible.FunctionHandle +import Lang.Crucible.LLVM.Eval (llvmExtensionEval) +import Lang.Crucible.Panic (panic) +import Lang.Crucible.LLVM.Extension (ArchWidth) +import Lang.Crucible.LLVM.Intrinsics +import Lang.Crucible.LLVM.MemModel + ( llvmStatementExec, HasPtrWidth, HasLLVMAnn, MemOptions, MemImpl + , Mem + ) +import Lang.Crucible.LLVM.Translation +import Lang.Crucible.Simulator (regValue, FnVal(..)) +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.OverrideSim + + +import What4.Interface (getCurrentProgramLoc) +import What4.ProgramLoc (plSourceLoc) + + +-- | Register all the functions defined in the LLVM module. +-- This will immediately build Crucible CFGs for each function +-- defined in the module. +registerModule :: + (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) => + (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} -> + ModuleTranslation arch -> + OverrideSim p sym LLVM rtp l a () +registerModule handleWarning mtrans = + mapM_ (registerModuleFn handleWarning mtrans) (map (L.decName.fst) (mtrans ^. modTransDefs)) + +-- | Register a specific named function that is defined in the given +-- module translation. This will immediately build a Crucible CFG for +-- the named function. +registerModuleFn :: + (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) => + (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} -> + ModuleTranslation arch -> + L.Symbol -> + OverrideSim p sym LLVM rtp l a () +registerModuleFn handleWarning mtrans sym = + liftIO (getTranslatedCFG mtrans sym) >>= \case + Nothing -> + fail $ unlines + [ "Could not find definition for function" + , show sym + ] + Just (decl, AnyCFG cfg, warns) -> do + let h = cfgHandle cfg + s = UseCFG cfg (postdomInfo cfg) + binds <- use (stateContext . functionBindings) + let llvmCtx = mtrans ^. transContext + bind_llvm_handle llvmCtx (L.decName decl) h s + + when (isJust $ lookupHandleMap h $ fnBindings binds) $ + do loc <- liftIO . getCurrentProgramLoc =<< getSymInterface + liftIO (handleWarning (LLVMTranslationWarning sym (plSourceLoc loc) "LLVM function handle registered twice")) + liftIO $ mapM_ handleWarning warns + +-- | Lazily register all the functions defined in the LLVM module. See +-- 'registerLazyModuleFn' for a description. +registerLazyModule :: + (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) => + (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling traslation warnings -} -> + ModuleTranslation arch -> + OverrideSim p sym LLVM rtp l a () +registerLazyModule handleWarning mtrans = + mapM_ (registerLazyModuleFn handleWarning mtrans) (map (L.decName.fst) (mtrans ^. modTransDefs)) + +-- | Lazily register the named function that is defnied in the given module +-- translation. This will delay actually translating the function until it +-- is called. This done by first installing a bootstrapping override that +-- will peform the actual translation when first invoked, and then will backpatch +-- its own references to point to the translated function. +-- +-- Note that the callback for printing translation warnings may be called at +-- a much-later point, when the function in question is actually first invoked. +registerLazyModuleFn :: + (1 <= ArchWidth arch, HasPtrWidth (ArchWidth arch), IsSymInterface sym) => + (LLVMTranslationWarning -> IO ()) {- ^ A callback for handling translation warnings -} -> + ModuleTranslation arch -> + L.Symbol -> + OverrideSim p sym LLVM rtp l a () +registerLazyModuleFn handleWarning mtrans sym = + liftIO (getTranslatedFnHandle mtrans sym) >>= \case + Nothing -> + fail $ unlines + [ "Could not find definition for function" + , show sym + ] + Just (decl, SomeHandle h) -> + do -- Bind the function handle we just created to the following bootstrapping code, + -- which actually translates the function on its first execution and patches up + -- behind itself. + let s = + UseOverride + $ mkOverride' (handleName h) (handleReturnType h) + $ -- This inner action defines what to do when this function is called for the + -- first time. We actually translate the function and install it as the + -- implementation for the function handle, instead of this bootstrapping code. + liftIO (getTranslatedCFG mtrans sym) >>= \case + Nothing -> + panic "registerLazyModuleFn" + [ "Could not find definition for function in bootstrapping code" + , show sym + ] + Just (_decl, AnyCFG cfg, warns) -> + case testEquality (handleType (cfgHandle cfg)) (handleType h) of + Nothing -> panic "registerLazyModuleFn" + ["Translated CFG type does not match function handle type", + show (handleType h), show (handleType (cfgHandle cfg)) ] + Just Refl -> + do liftIO $ mapM_ handleWarning warns + -- Here we rebind the function handle to use the translated CFG + bindFnHandle h (UseCFG cfg (postdomInfo cfg)) + -- Now, make recursive call to ourself, which should invoke the + -- newly-installed CFG + regValue <$> (callFnVal (HandleFnVal h) =<< getOverrideArgs) + + -- Bind the function handle to the appropriate global symbol. + let llvmCtx = mtrans ^. transContext + bind_llvm_handle llvmCtx (L.decName decl) h s + + +llvmGlobalsToCtx + :: LLVMContext arch + -> MemImpl sym + -> SymGlobalState sym +llvmGlobalsToCtx = llvmGlobals . llvmMemVar + +llvmGlobals + :: GlobalVar Mem + -> MemImpl sym + -> SymGlobalState sym +llvmGlobals memVar mem = emptyGlobals & insertGlobal memVar mem + +llvmExtensionImpl :: + (HasLLVMAnn sym) => + MemOptions -> + ExtensionImpl p sym LLVM +llvmExtensionImpl mo = + let ?memOpts = mo in + ExtensionImpl + { extensionEval = llvmExtensionEval + , extensionExec = llvmStatementExec + } diff --git a/src/Lang/Crucible/LLVM/Arch/Util.hs b/src/Lang/Crucible/LLVM/Arch/Util.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Arch/Util.hs @@ -0,0 +1,6 @@ +module Lang.Crucible.LLVM.Arch.Util where + + + +(|->) :: a -> b -> (a, b) +p |-> x = (p,x) diff --git a/src/Lang/Crucible/LLVM/Arch/X86.hs b/src/Lang/Crucible/LLVM/Arch/X86.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Arch/X86.hs @@ -0,0 +1,176 @@ +{-# Language GADTs #-} +{-# Language DataKinds #-} +{-# Language KindSignatures #-} +{-# Language TypeOperators #-} +{-# Language ExplicitNamespaces #-} +{-# Language TemplateHaskell #-} +{-# Language RankNTypes #-} +{-# Language ScopedTypeVariables #-} +{-# Language PatternGuards #-} +{-# Language MultiWayIf #-} +module Lang.Crucible.LLVM.Arch.X86 where + +import qualified Data.BitVector.Sized as BV +import Data.Word(Word8) +import Data.Bits +import Data.Kind +import GHC.TypeNats (type (<=)) + +import Data.Parameterized.NatRepr(knownNat) +import Data.Parameterized.Classes(testEquality,compareF) +import Data.Parameterized.TraversableFC +import Data.Parameterized.TH.GADT as U + +import What4.Interface (SymBV) +import qualified What4.Interface as I + +import Lang.Crucible.CFG.Extension +import Lang.Crucible.Types(CrucibleType,BVType,NatRepr,TypeRepr(..)) +import Lang.Crucible.Simulator.RegValue(RegValue) +import Lang.Crucible.Panic(panic) + +import Lang.Crucible.LLVM.Arch.Util((|->)) + +data AVXOp1 = VShiftL Word8 -- ^ Shift left by this many bytes + -- New bytes are 0. + | VShufD Word8 -- ^ Shuffle 32-bit words of vector + -- according to pattern in the word8 + deriving (Eq,Ord) + + +data ExtX86 :: (CrucibleType -> Type) -> CrucibleType -> Type where + + {- | Unary operation on a vector. Should have no side effects. -} + VOp1 :: (1 <= n) => + !(NatRepr n) -> {- width of input/result -} + !AVXOp1 -> {- do this operation -} + !(f (BVType n)) -> {- on this thing -} + ExtX86 f (BVType n) + + + +eval :: forall sym f tp. + I.IsSymExprBuilder sym => + sym -> + (forall subT. f subT -> IO (RegValue sym subT)) -> + ExtX86 f tp -> + IO (RegValue sym tp) +eval sym ev ext = + case ext of + VOp1 w op e -> + case op of + VShiftL amt -> vShiftL sym w amt =<< ev e + VShufD ixes -> vShufD sym w ixes =<< ev e + + +-- | See @vpslldq@ +vShiftL :: (I.IsSymExprBuilder sym, 1 <= w) => + sym -> NatRepr w -> Word8 -> SymBV sym w -> IO (SymBV sym w) +vShiftL sym w amt v = + do i <- I.bvLit sym w (BV.mkBV w (8 * fromIntegral amt)) + I.bvShl sym v i + + +-- | See @vpshufd@ +vShufD :: forall sym w. + I.IsSymExprBuilder sym => + sym -> NatRepr w -> Word8 -> SymBV sym w -> IO (SymBV sym w) +vShufD sym w ixes v + | Just I.Refl <- testEquality w n128 = mk128 v + | Just I.Refl <- testEquality w n256 = + do lower128 <- mk128 =<< I.bvSelect sym n0 n128 v + upper128 <- mk128 =<< I.bvSelect sym n128 n128 v + I.bvConcat sym upper128 lower128 + | otherwise = panic "Arch.X86.vShufD" + [ "*** Unexpected width: " ++ show (I.natValue w) ] + + where + mk128 :: SymBV sym 128 -> IO (SymBV sym 128) + mk128 src = do f0 <- getV src 0 + f1 <- getV src 1 + f2 <- getV src 2 + f3 <- getV src 3 + lower64 <- I.bvConcat sym f1 f0 + upper64 <- I.bvConcat sym f3 f2 + I.bvConcat sym upper64 lower64 + + getV :: SymBV sym 128 -> Int -> IO (SymBV sym 32) + getV src n = case getIx n of + 0 -> I.bvSelect sym n0 n32 src + 1 -> I.bvSelect sym n1 n32 src + 2 -> I.bvSelect sym n2 n32 src + _ -> I.bvSelect sym n3 n32 src + + getIx :: Int -> Word8 + getIx n = (ixes `shiftR` (2 * n)) .&. 0x03 -- get 2 bit field + + + + +-------------------------------------------------------------------------------- +n0 :: NatRepr 0 +n0 = knownNat + +n1 :: NatRepr 1 +n1 = knownNat + +n2 :: NatRepr 2 +n2 = knownNat + +n3 :: NatRepr 3 +n3 = knownNat + +n32 :: NatRepr 32 +n32 = knownNat + +n128 :: NatRepr 128 +n128 = knownNat + +n256 :: NatRepr 256 +n256 = knownNat + + +-------------------------------------------------------------------------------- + +$([d| {- New TH Scope -} |]) + + +-- This is going to go away +instance ShowFC ExtX86 where + showFC _ _ = error "[ShowFC ExtX86] Not implmented." + +instance TestEqualityFC ExtX86 where + testEqualityFC testSubterm = + $(U.structuralTypeEquality [t| ExtX86 |] + [ U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType |-> [|testEquality|] + , U.DataArg 0 `U.TypeApp` U.AnyType |-> [|testSubterm|] + ]) + +instance OrdFC ExtX86 where + compareFC testSubterm = + $(U.structuralTypeOrd [t| ExtX86 |] + [ U.ConType [t|NatRepr |] `U.TypeApp` U.AnyType |-> [|compareF|] + , U.DataArg 0 `U.TypeApp` U.AnyType |-> [|testSubterm|] + ]) + +-- This is going away +instance HashableFC ExtX86 where + hashWithSaltFC _hash _s _x = error "[HashableFC ExtX86] Not implmented." + +instance FunctorFC ExtX86 where + fmapFC = fmapFCDefault + +instance FoldableFC ExtX86 where + foldMapFC = foldMapFCDefault + +instance TraversableFC ExtX86 where + traverseFC = $(U.structuralTraversal [t|ExtX86|] []) + +instance PrettyApp ExtX86 where + ppApp _pp _x = error "[PrettyApp ExtX86] XXX" + +instance TypeApp ExtX86 where + appType x = + case x of + VOp1 w _ _ -> BVRepr w + diff --git a/src/Lang/Crucible/LLVM/ArraySizeProfile.hs b/src/Lang/Crucible/LLVM/ArraySizeProfile.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/ArraySizeProfile.hs @@ -0,0 +1,208 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.ArraySizeProfile +-- Description : Execution feature to observe argument buffer sizes +-- Copyright : (c) Galois, Inc 2020 +-- License : BSD3 +-- Maintainer : Samuel Breese +-- Stability : provisional +------------------------------------------------------------------------ + +{-# Options -Wall #-} +{-# Language TemplateHaskell #-} +{-# Language OverloadedStrings #-} +{-# Language LambdaCase #-} +{-# Language MultiWayIf #-} +{-# Language ImplicitParams #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +{-# Language BangPatterns #-} +{-# Language FlexibleContexts #-} +{-# Language ScopedTypeVariables #-} +{-# Language DataKinds #-} +{-# Language KindSignatures #-} +{-# Language TypeFamilies #-} +{-# Language TypeApplications #-} +{-# Language GADTs #-} + +module Lang.Crucible.LLVM.ArraySizeProfile + ( FunctionProfile(..), funProfileName, funProfileArgs + , ArgProfile(..), argProfileSize, argProfileInitialized + , arraySizeProfile + ) where + +import Control.Lens.TH + +import Control.Lens + +import Data.Type.Equality (testEquality) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import Data.Map (Map) +import qualified Data.Map as Map + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.SymbolRepr +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.TraversableFC + +import qualified Lang.Crucible.Backend as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.Simulator.CallFrame as C +import qualified Lang.Crucible.Simulator.EvalStmt as C +import qualified Lang.Crucible.Simulator.ExecutionTree as C +import qualified Lang.Crucible.Simulator.GlobalState as C +import qualified Lang.Crucible.Simulator.Intrinsics as C +import qualified Lang.Crucible.Simulator.RegMap as C + +import qualified Lang.Crucible.LLVM.DataLayout as C +import qualified Lang.Crucible.LLVM.Extension as C +import qualified Lang.Crucible.LLVM.MemModel as C +import qualified Lang.Crucible.LLVM.MemModel.Generic as G +import qualified Lang.Crucible.LLVM.Translation.Monad as C + +import qualified What4.Interface as W4 + +------------------------------------------------------------------------ +-- Profiles + +data ArgProfile = ArgProfile + { _argProfileSize :: Maybe Int + , _argProfileInitialized :: Bool + } deriving (Show, Eq, Ord) +makeLenses ''ArgProfile + +data FunctionProfile = FunctionProfile + { _funProfileName :: Text + , _funProfileArgs :: [ArgProfile] + } deriving (Show, Eq, Ord) +makeLenses ''FunctionProfile + +------------------------------------------------------------------------ +-- Learning a profile from an ExecState + +ptrStartsAlloc :: + W4.IsExpr (W4.SymExpr sym) => + C.LLVMPtr sym w -> + Bool +ptrStartsAlloc (C.llvmPointerView -> (_, W4.asBV -> Just (BV.BV 0))) = True +ptrStartsAlloc _ = False + +ptrAllocSize :: + forall sym w. + C.IsSymInterface sym => + G.Mem sym -> + C.LLVMPtr sym w -> + Maybe Int +ptrAllocSize mem (C.llvmPointerView -> (blk, _)) = + do a <- W4.asNat blk + G.AllocInfo _ msz _ _ _ <- G.possibleAllocInfo a (G.memAllocs mem) + sz <- msz + fromIntegral <$> BV.asUnsigned <$> W4.asBV sz + +ptrArraySize :: + C.IsSymInterface sym => + G.Mem sym -> + C.LLVMPtr sym w -> + Maybe Int +ptrArraySize mem ptr + | ptrStartsAlloc ptr = ptrAllocSize mem ptr + | otherwise = Nothing + +ptrIsInitialized :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w + , ?memOpts :: C.MemOptions ) => + sym -> + G.Mem sym -> + C.LLVMPtr sym w -> + IO Bool +ptrIsInitialized sym mem ptr = + G.readMem sym C.PtrWidth Nothing ptr (C.bitvectorType 1) C.noAlignment mem >>= \case + C.NoErr{} -> pure True + _ -> pure False + +intrinsicArgProfile :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w + , ?memOpts :: C.MemOptions ) => + sym -> + G.Mem sym -> + SymbolRepr nm -> + C.CtxRepr ctx -> + C.Intrinsic sym nm ctx -> + IO ArgProfile +intrinsicArgProfile sym mem + (testEquality (knownSymbol :: SymbolRepr "LLVM_pointer") -> Just Refl) + (Ctx.Empty Ctx.:> C.BVRepr (testEquality ?ptrWidth -> Just Refl)) i = + ArgProfile (ptrArraySize mem i) <$> ptrIsInitialized sym mem i +intrinsicArgProfile _ _ _ _ _ = pure $ ArgProfile Nothing False + +regValueArgProfile :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w + , ?memOpts :: C.MemOptions ) => + sym -> + G.Mem sym -> + C.TypeRepr tp -> + C.RegValue sym tp -> + IO ArgProfile +regValueArgProfile sym mem (C.IntrinsicRepr nm ctx) i = intrinsicArgProfile sym mem nm ctx i +regValueArgProfile _ _ _ _ = pure $ ArgProfile Nothing False + +regEntryArgProfile :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w + , ?memOpts :: C.MemOptions ) => + sym -> + G.Mem sym -> + C.RegEntry sym tp -> + IO ArgProfile +regEntryArgProfile sym mem (C.RegEntry t v) = regValueArgProfile sym mem t v + +newtype Wrap a (b :: C.CrucibleType) = Wrap { unwrap :: a } +argProfiles :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth w + , ?memOpts :: C.MemOptions ) => + sym -> + G.Mem sym -> + Ctx.Assignment (C.RegEntry sym) ctx -> + IO [ArgProfile] +argProfiles sym mem as = + sequence (Vector.toList $ Ctx.toVector (fmapFC (Wrap . regEntryArgProfile sym mem) as) unwrap) + +------------------------------------------------------------------------ +-- Execution feature for learning profiles + +updateProfiles :: + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth (C.ArchWidth arch) + , ?memOpts :: C.MemOptions ) => + C.LLVMContext arch -> + IORef (Map Text [FunctionProfile]) -> + C.ExecState p sym ext rtp -> + IO () +updateProfiles llvm cell state + | C.CallState _ (C.CrucibleCall _ frame) sim <- state + , C.CallFrame { C._frameCFG = cfg, C._frameRegs = regs } <- frame + , Just mem <- C.memImplHeap <$> C.lookupGlobal (C.llvmMemVar llvm) (sim ^. C.stateGlobals) + = do + argProfs <- argProfiles (sim ^. C.stateSymInterface) mem $ C.regMap regs + modifyIORef' cell $ \profs -> + let name = Text.pack . show $ C.cfgHandle cfg + funProf = FunctionProfile name argProfs + in case Map.lookup name profs of + Nothing -> Map.insert name [funProf] profs + Just variants + | funProf `elem` variants -> profs + | otherwise -> Map.insert name (funProf:variants) profs + | otherwise = pure () + +arraySizeProfile :: + forall sym ext arch p rtp. + ( C.IsSymInterface sym, C.HasLLVMAnn sym, C.HasPtrWidth (C.ArchWidth arch) + , ?memOpts :: C.MemOptions ) => + C.LLVMContext arch -> + IORef (Map Text [FunctionProfile]) -> + IO (C.ExecutionFeature p sym ext rtp) +arraySizeProfile llvm profiles = do + pure . C.ExecutionFeature $ \s -> do + updateProfiles llvm profiles s + pure C.ExecutionFeatureNoChange diff --git a/src/Lang/Crucible/LLVM/Bytes.hs b/src/Lang/Crucible/LLVM/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Bytes.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Bytes +-- Description : A type representing numbers of bytes. +-- Copyright : (c) Galois, Inc 2011-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Lang.Crucible.LLVM.Bytes + ( -- * Bytes + Bytes(..) + , Addr + , Offset + , bytesToBits + , bytesToNatural + , bytesToInteger + , bytesToBV + , toBytes + , bitsToBytes + , natBytesMul + ) where + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.NatRepr +import Numeric.Natural + +-- | A newtype for expressing numbers of bytes. +-- This newtype is explicitly introduced to avoid confusion +-- between widths expressed as numbers of bits vs numbers of bytes. +newtype Bytes = Bytes { unBytes :: Integer } + deriving (Eq, Ord, Num, Enum, Real, Integral) + +instance Show Bytes where + show (Bytes n) = show n + +bytesToBits :: Bytes -> Natural +bytesToBits (Bytes n) = 8 * fromIntegral n + +bytesToNatural :: Bytes -> Natural +bytesToNatural (Bytes n) = fromIntegral n + +bytesToInteger :: Bytes -> Integer +bytesToInteger (Bytes n) = n + +bytesToBV :: NatRepr w -> Bytes -> BV.BV w +bytesToBV w = BV.mkBV w . bytesToInteger + +toBytes :: Integral a => a -> Bytes +toBytes = Bytes . fromIntegral + +bitsToBytes :: Integral a => a -> Bytes +bitsToBytes n = Bytes ( (fromIntegral n + 7) `div` 8 ) + +-- | Multiply a number of bytes by a natural number +natBytesMul :: Natural -> Bytes -> Bytes +natBytesMul n (Bytes x) = Bytes (toInteger n * x) + +type Addr = Bytes +type Offset = Bytes diff --git a/src/Lang/Crucible/LLVM/Ctors.hs b/src/Lang/Crucible/LLVM/Ctors.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Ctors.hs @@ -0,0 +1,190 @@ + ------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Ctors +-- Description : Extract and manipulate the @llvm.global_ctors@ variable +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Ctors + ( Ctor(..) + , globalCtors + , callCtors + , callAllCtors + , callCtorsCFG + ) where + +import Data.Data (Data) +import Data.IORef (newIORef) +import Data.String(fromString) +import Data.Typeable (Typeable) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Data.Parameterized.Nonce + +import Control.Monad (forM, forM_) +import Control.Monad.Except (MonadError(..)) +import Data.List (find, sortBy) +import Data.Ord (comparing, Down(..)) +import Data.Maybe (fromMaybe) + +import qualified Text.LLVM.AST as L + +import Lang.Crucible.LLVM.Translation.Instruction (callOrdinaryFunction) +import Lang.Crucible.LLVM.Translation.Monad (LLVMGenerator, LLVMState(..)) + +-- Generating CFGs + +import Data.Map.Strict (empty) +import Data.Text (Text) +import GHC.TypeNats + +import qualified Data.Parameterized.Context.Unsafe as Ctx + +import What4.FunctionName (functionNameFromText) +import What4.ProgramLoc (Position(InternalPos)) + +import qualified Lang.Crucible.CFG.Core as Core +import Lang.Crucible.CFG.Expr (App(EmptyApp)) +import Lang.Crucible.CFG.Generator (FunctionDef, defineFunction) +import Lang.Crucible.CFG.Reg (Expr(App)) +import qualified Lang.Crucible.CFG.Reg as Reg +import Lang.Crucible.CFG.SSAConversion (toSSA) +import Lang.Crucible.FunctionHandle (HandleAllocator, mkHandle') +import Lang.Crucible.Types (UnitType, TypeRepr(UnitRepr)) +import Lang.Crucible.LLVM.Extension (LLVM, ArchWidth) +import Lang.Crucible.LLVM.Translation.Monad (LLVMContext, _llvmTypeCtx, malformedLLVMModule) +import Lang.Crucible.LLVM.Types (HasPtrWidth) + +{- Example: + +@llvm.global_ctors = appending global [3 x { i32, void ()*, i8* }] [{ i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_HkdfTest.cpp, i8* null }, { i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_gtest_all.cc, i8* null }, { i32, void ()*, i8* } { i32 65535, void ()* @_GLOBAL__sub_I_iostream.cpp, i8* null }] + +-} + +-- | A representation of well-typed inhabitants of the @llvm.global_ctors@ array +-- +-- See https://llvm.org/docs/LangRef.html#the-llvm-global-ctors-global-variable +data Ctor = Ctor + { ctorPriority :: Integer + , ctorFunction :: L.Symbol + , ctorData :: Maybe L.Symbol + } deriving (Data, Eq, Generic, Ord, Show, Typeable) + +-- | Get the global variable representing @llvm.global_ctors@. +getGlobalCtorsGlobal :: L.Module -> Maybe L.Global +getGlobalCtorsGlobal mod_ = + let symb = L.Symbol "llvm.global_ctors" + in find (\x -> L.globalSym x == symb) (L.modGlobals mod_) + +-- | Unpack a @ctors@ value of type @{ i32, void ()*, i8* }@ from the AST +extractCtors :: L.Value -> Maybe Ctor +extractCtors val = + case val of + -- This is permissive about the integer widths... No reason to get caught up. + L.ValStruct [ L.Typed (L.PrimType (L.Integer _w0)) (L.ValInteger priority) + , L.Typed (L.PtrTo (L.FunTy (L.PrimType L.Void) [] _bool)) (L.ValSymbol symb) + , L.Typed (L.PtrTo (L.PrimType (L.Integer _w1))) data0_ + ] -> Just . Ctor priority symb $ + case data0_ of + L.ValSymbol data_ -> Just data_ + _ -> Nothing + _ -> Nothing + +-- | Unpack and sort the values in @llvm.global_ctors@ by priority +globalCtors :: (MonadError String m) + => L.Module + -> m [Ctor] +globalCtors mod_ = + case getGlobalCtorsGlobal mod_ >>= L.globalValue of -- in the Maybe monad + Just (L.ValArray _ty vs) -> do + + -- Assert that each value is of the expected type. + vs' <- forM vs $ \v -> + fromMaybe + (throwError $ unlines $ [ "Ill-typed value in llvm.global_ctors: " + , show v + ]) + (pure <$> extractCtors v) + + -- Sort the values by priority, highest to lowest. + pure (sortBy (comparing (Down . ctorPriority)) vs') + + -- @llvm.ctors value not found, assume there are no global_ctors to run + Nothing -> return [] + + Just v -> throwError $ unlines $ + [ "llvm.global_ctors wasn't an array" + , "Value: " ++ show v + ] + +---------------------------------------------------------------------- +-- ** callCtors + +-- | Call some or all of the functions in @llvm.global_ctors@ +callCtors :: (Ctor -> Bool) -- ^ Filter function + -> L.Module + -> LLVMGenerator s arch UnitType (Expr LLVM s UnitType) +callCtors select mod_ = do + let err msg = malformedLLVMModule "Error loading @llvm.global_ctors" [fromString msg] + let ty = L.FunTy (L.PrimType L.Void) [] False + + ctors <- either err (pure . filter select) (globalCtors mod_) + forM_ ctors $ \ctor -> + callOrdinaryFunction Nothing False ty (L.ValSymbol (ctorFunction ctor)) [] (\_ -> pure ()) + return (App EmptyApp) + +-- | Call each function in @llvm.global_ctors@ in order of decreasing priority +callAllCtors :: L.Module -> LLVMGenerator s arch UnitType (Expr LLVM s UnitType) +callAllCtors = callCtors (const True) + +---------------------------------------------------------------------- +-- ** callCtorsCFG + +-- | Make a 'LLVMGenerator' into a CFG by making it a function with no arguments +-- that returns unit. +generatorToCFG :: forall arch wptr ret. (HasPtrWidth wptr, wptr ~ ArchWidth arch, 16 <= wptr) + => Text + -> HandleAllocator + -> LLVMContext arch + -> (forall s. LLVMGenerator s arch ret (Expr LLVM s ret)) + -> TypeRepr ret + -> IO (Core.SomeCFG LLVM Core.EmptyCtx ret) +generatorToCFG name halloc llvmctx gen ret = do + ref <- newIORef [] + let ?lc = _llvmTypeCtx llvmctx + let def :: forall args. FunctionDef LLVM (LLVMState arch) args ret IO + def _inputs = (state, gen) + where state = LLVMState { _identMap = empty + , _blockInfoMap = empty + , llvmContext = llvmctx + , _translationWarnings = ref + , _functionSymbol = L.Symbol (Text.unpack name) + } + + hand <- mkHandle' halloc (functionNameFromText name) Ctx.empty ret + sng <- newIONonceGenerator + (Reg.SomeCFG g, []) <- defineFunction InternalPos sng hand def + return $! toSSA g + +-- | Create a CFG that calls some of the functions in @llvm.global_ctors@. +callCtorsCFG :: forall arch wptr. (HasPtrWidth wptr, wptr ~ ArchWidth arch, 16 <= wptr) + => (Ctor -> Bool) -- ^ Filter function + -> L.Module + -> HandleAllocator + -> LLVMContext arch + -> IO (Core.SomeCFG LLVM Core.EmptyCtx UnitType) +callCtorsCFG select mod_ halloc llvmctx = do + generatorToCFG "llvm_global_ctors" halloc llvmctx (callCtors select mod_) UnitRepr diff --git a/src/Lang/Crucible/LLVM/DataLayout.hs b/src/Lang/Crucible/LLVM/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/DataLayout.hs @@ -0,0 +1,333 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.DataLayout +-- Description : Basic datatypes for describing memory layout and alignment +-- Copyright : (c) Galois, Inc 2011-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.DataLayout + ( -- * Alignments + Alignment + , noAlignment + , padToAlignment + , toAlignment + , fromAlignment + , exponentToAlignment + , alignmentToExponent + -- * Data layout declarations. + , DataLayout + , EndianForm(..) + , intLayout + , maxAlignment + , ptrSize + , ptrAlign + , ptrBitwidth + , defaultDataLayout + , parseDataLayout + , integerAlignment + , vectorAlignment + , floatAlignment + , aggregateAlignment + , intWidthSize + ) where + +import Control.Lens +import Control.Monad.State.Strict +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Word (Word32) +import qualified Text.LLVM as L +import Numeric.Natural + +import What4.Utils.Arithmetic +import Lang.Crucible.LLVM.Bytes + + +------------------------------------------------------------------------ +-- Data layout + +-- | An @Alignment@ represents a number of bytes that must be a power of two. +newtype Alignment = Alignment Word32 + deriving (Eq, Ord, Show) +-- The representation just stores the exponent. E.g., @Alignment 3@ +-- indicates alignment to a 2^3-byte boundary. + +-- | 1-byte alignment, which is the minimum possible. +noAlignment :: Alignment +noAlignment = Alignment 0 + +-- | @padToAlignment x a@ returns the smallest value greater than or +-- equal to @x@ that is aligned to @a@. +padToAlignment :: Bytes -> Alignment -> Bytes +padToAlignment x (Alignment n) = toBytes (nextPow2Multiple (bytesToNatural x) (fromIntegral n)) + +-- | Convert a number of bytes into an alignment, if it is a power of 2. +toAlignment :: Bytes -> Maybe Alignment +toAlignment (Bytes x) + | isPow2 x = Just (Alignment (fromIntegral (lg x))) + | otherwise = Nothing + +-- | Convert an alignment to a number of bytes. +fromAlignment :: Alignment -> Bytes +fromAlignment (Alignment n) = Bytes (2 ^ n) + +-- | Convert an exponent @n@ to an alignment of @2^n@ bytes. +exponentToAlignment :: Natural -> Alignment +exponentToAlignment n = Alignment (fromIntegral n) + +alignmentToExponent :: Alignment -> Natural +alignmentToExponent (Alignment n) = fromIntegral n + +newtype AlignInfo = AT (Map Natural Alignment) + deriving (Eq, Ord) + +-- | Make alignment info containing no alignments. +emptyAlignInfo :: AlignInfo +emptyAlignInfo = AT Map.empty + +-- | Return alignment exactly at point if any. +findExact :: Natural -> AlignInfo -> Maybe Alignment +findExact w (AT t) = Map.lookup w t + +-- | Get alignment for the integer type of the specified bitwidth, +-- using LLVM's rules for integer types: "If no match is found, and +-- the type sought is an integer type, then the smallest integer type +-- that is larger than the bitwidth of the sought type is used. If +-- none of the specifications are larger than the bitwidth then the +-- largest integer type is used." +-- +integerAlignment :: DataLayout -> Natural -> Alignment +integerAlignment dl w = + case Map.lookupGE w t of + Just (_, a) -> a + Nothing -> + case Map.toDescList t of + ((_, a) : _) -> a + _ -> noAlignment + where AT t = dl^.integerInfo + +-- | Get alignment for a vector type of the specified bitwidth, using +-- LLVM's rules for vector types: "If no match is found, and the type +-- sought is a vector type, then the largest vector type that is +-- smaller than the sought vector type will be used as a fall back." +-- +vectorAlignment :: DataLayout -> Natural -> Alignment +vectorAlignment dl w = + case Map.lookupLE w t of + Just (_, a) -> a + Nothing -> noAlignment + where AT t = dl^.vectorInfo + +-- | Get alignment for a float type of the specified bitwidth. +floatAlignment :: DataLayout -> Natural -> Maybe Alignment +floatAlignment dl w = Map.lookup w t + where AT t = dl^.floatInfo + +-- | Get the basic alignment for aggregate types. +aggregateAlignment :: DataLayout -> Alignment +aggregateAlignment dl = + fromMaybe noAlignment (findExact 0 (dl^.aggInfo)) + +-- | Return maximum alignment constraint stored in tree. +maxAlignmentInTree :: AlignInfo -> Alignment +maxAlignmentInTree (AT t) = foldrOf folded max noAlignment t + +-- | Update alignment tree +updateAlign :: Natural + -> AlignInfo + -> Maybe Alignment + -> AlignInfo +updateAlign w (AT t) ma = AT (Map.alter (const ma) w t) + +type instance Index AlignInfo = Natural +type instance IxValue AlignInfo = Alignment + +instance Ixed AlignInfo where + ix k = at k . traverse + +instance At AlignInfo where + at k f m = updateAlign k m <$> indexed f k (findExact k m) + +-- | Flags byte orientation of target machine. +data EndianForm = BigEndian | LittleEndian + deriving (Eq, Ord, Show) + +-- | Parsed data layout +data DataLayout + = DL { _intLayout :: EndianForm + , _stackAlignment :: !Alignment + , _ptrSize :: !Bytes + , _ptrAlign :: !Alignment + , _integerInfo :: !AlignInfo + , _vectorInfo :: !AlignInfo + , _floatInfo :: !AlignInfo + , _aggInfo :: !AlignInfo + , _stackInfo :: !AlignInfo + , _layoutWarnings :: [L.LayoutSpec] + } + deriving (Eq, Ord) + +instance Show DataLayout where + show _ = "<>" + +intLayout :: Lens' DataLayout EndianForm +intLayout = lens _intLayout (\s v -> s { _intLayout = v}) + +stackAlignment :: Lens' DataLayout Alignment +stackAlignment = lens _stackAlignment (\s v -> s { _stackAlignment = v}) + +-- | Size of pointers in bytes. +ptrSize :: Lens' DataLayout Bytes +ptrSize = lens _ptrSize (\s v -> s { _ptrSize = v}) + +-- | ABI pointer alignment in bytes. +ptrAlign :: Lens' DataLayout Alignment +ptrAlign = lens _ptrAlign (\s v -> s { _ptrAlign = v}) + +integerInfo :: Lens' DataLayout AlignInfo +integerInfo = lens _integerInfo (\s v -> s { _integerInfo = v}) + +vectorInfo :: Lens' DataLayout AlignInfo +vectorInfo = lens _vectorInfo (\s v -> s { _vectorInfo = v}) + +floatInfo :: Lens' DataLayout AlignInfo +floatInfo = lens _floatInfo (\s v -> s { _floatInfo = v}) + +-- | Information about aggregate size. +aggInfo :: Lens' DataLayout AlignInfo +aggInfo = lens _aggInfo (\s v -> s { _aggInfo = v}) + +-- | Layout constraints on a stack object with the given size. +stackInfo :: Lens' DataLayout AlignInfo +stackInfo = lens _stackInfo (\s v -> s { _stackInfo = v}) + +-- | Layout specs that could not be parsed. +layoutWarnings :: Lens' DataLayout [L.LayoutSpec] +layoutWarnings = lens _layoutWarnings (\s v -> s { _layoutWarnings = v}) + +ptrBitwidth :: DataLayout -> Natural +ptrBitwidth dl = bytesToBits (dl^.ptrSize) + +-- | Reduce the bit level alignment to a byte value, and error if it is not +-- a multiple of 8. +fromBits :: Int -> Either String Alignment +fromBits a | w <= 0 = Left $ "Alignment must be a positive number." + | r /= 0 = Left $ "Alignment specification must occupy a byte boundary." + | not (isPow2 w) = Left $ "Alignment must be a power of two." + | otherwise = Right $ Alignment (fromIntegral (lg w)) + where (w,r) = toInteger a `divMod` 8 + +-- | Insert alignment into spec. +setAt :: Lens' DataLayout AlignInfo -> Natural -> Alignment -> State DataLayout () +setAt f sz a = f . at sz ?= a + +-- | The default data layout if no spec is defined. From the LLVM +-- Language Reference: "When constructing the data layout for a given +-- target, LLVM starts with a default set of specifications which are +-- then (possibly) overridden by the specifications in the datalayout +-- keyword." +defaultDataLayout :: DataLayout +defaultDataLayout = execState defaults dl + where dl = DL { _intLayout = BigEndian + , _stackAlignment = noAlignment + , _ptrSize = 8 -- 64 bit pointers = 8 bytes + , _ptrAlign = Alignment 3 -- 64 bit alignment: 2^3=8 byte boundaries + , _integerInfo = emptyAlignInfo + , _floatInfo = emptyAlignInfo + , _vectorInfo = emptyAlignInfo + , _aggInfo = emptyAlignInfo + , _stackInfo = emptyAlignInfo + , _layoutWarnings = [] + } + defaults = do + -- Default integer alignments + setAt integerInfo 1 noAlignment -- 1-bit values aligned on byte addresses. + setAt integerInfo 8 noAlignment -- 8-bit values aligned on byte addresses. + setAt integerInfo 16 (Alignment 1) -- 16-bit values aligned on 2 byte addresses. + setAt integerInfo 32 (Alignment 2) -- 32-bit values aligned on 4 byte addresses. + setAt integerInfo 64 (Alignment 3) -- 64-bit values aligned on 8 byte addresses. + -- Default float alignments + setAt floatInfo 16 (Alignment 1) -- Half is aligned on 2 byte addresses. + setAt floatInfo 32 (Alignment 2) -- Float is aligned on 4 byte addresses. + setAt floatInfo 64 (Alignment 3) -- Double is aligned on 8 byte addresses. + setAt floatInfo 128 (Alignment 4) -- Quad is aligned on 16 byte addresses. + -- Default vector alignments. + setAt vectorInfo 64 (Alignment 3) -- 64-bit vector is 8 byte aligned. + setAt vectorInfo 128 (Alignment 4) -- 128-bit vector is 16 byte aligned. + -- Default aggregate alignments. + setAt aggInfo 0 noAlignment -- Aggregates are 1-byte aligned. + +-- | Maximum alignment for any type (used by malloc). +maxAlignment :: DataLayout -> Alignment +maxAlignment dl = + maximum [ dl^.stackAlignment + , dl^.ptrAlign + , maxAlignmentInTree (dl^.integerInfo) + , maxAlignmentInTree (dl^.vectorInfo) + , maxAlignmentInTree (dl^.floatInfo) + , maxAlignmentInTree (dl^.aggInfo) + , maxAlignmentInTree (dl^.stackInfo) + ] + +fromSize :: Int -> Natural +fromSize i | i < 0 = error $ "Negative size given in data layout." + | otherwise = fromIntegral i + +-- | Insert alignment into spec. +setAtBits :: Lens' DataLayout AlignInfo -> L.LayoutSpec -> Int -> Int -> State DataLayout () +setAtBits f spec sz a = + case fromBits a of + Left{} -> layoutWarnings %= (spec:) + Right w -> f . at (fromSize sz) .= Just w + +-- | Insert alignment into spec. +setBits :: Lens' DataLayout Alignment -> L.LayoutSpec -> Int -> State DataLayout () +setBits f spec a = + case fromBits a of + Left{} -> layoutWarnings %= (spec:) + Right w -> f .= w + +-- | Add information from layout spec into parsed data layout. +addLayoutSpec :: L.LayoutSpec -> State DataLayout () +addLayoutSpec ls = + -- TODO: Check that sizes and alignment is using bits versus bytes consistently. + case ls of + L.BigEndian -> intLayout .= BigEndian + L.LittleEndian -> intLayout .= LittleEndian + L.PointerSize n sz a _ + -- Currently, we assume that only default address space (0) is used. + -- We use that address space as the sole arbiter of what pointer + -- size to use, and we ignore all other PointerSize layout specs. + -- See doc/limitations.md for more discussion. + | n == 0 + -> case fromBits a of + Right a' | r == 0 -> do ptrSize .= fromIntegral w + ptrAlign .= a' + _ -> layoutWarnings %= (ls:) + | otherwise + -> return () + where (w,r) = sz `divMod` 8 + L.IntegerSize sz a _ -> setAtBits integerInfo ls sz a + L.VectorSize sz a _ -> setAtBits vectorInfo ls sz a + L.FloatSize sz a _ -> setAtBits floatInfo ls sz a + L.AggregateSize sz a _ -> setAtBits aggInfo ls sz a + L.StackObjSize sz a _ -> setAtBits stackInfo ls sz a + L.NativeIntSize _ -> return () + L.StackAlign a -> setBits stackAlignment ls a + L.Mangling _ -> return () + +-- | Create parsed data layout from layout spec AST. +parseDataLayout :: L.DataLayout -> DataLayout +parseDataLayout dl = execState (mapM_ addLayoutSpec dl) defaultDataLayout + +-- | The size of an integer of the given bitwidth, in bytes. +intWidthSize :: Natural -> Bytes +intWidthSize w = bitsToBytes w diff --git a/src/Lang/Crucible/LLVM/Errors.hs b/src/Lang/Crucible/LLVM/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Errors.hs @@ -0,0 +1,151 @@ +-- | +-- Module : Lang.Crucible.LLVM.Errors +-- Description : Safety assertions for the LLVM syntax extension +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Errors + ( LLVMSafetyAssertion + , BadBehavior(..) + , undefinedBehavior + , undefinedBehavior' + , poison + , poison' + , memoryError + , detailBB + , explainBB + , ppBB + , concBadBehavior + -- ** Lenses + , classifier + , predicate + , extra + ) where + +import Prelude hiding (pred) + +import Control.Lens +import Data.Text (Text) + +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Prettyprinter + +import What4.Interface +import What4.Expr (GroundValue) + +import Lang.Crucible.Simulator.RegValue (RegValue'(..)) +import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME +import qualified Lang.Crucible.LLVM.Errors.Poison as Poison +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB + +-- ----------------------------------------------------------------------- +-- ** BadBehavior + +-- | Combine the three types of bad behaviors +-- +data BadBehavior sym where + BBUndefinedBehavior :: UB.UndefinedBehavior (RegValue' sym) -> BadBehavior sym + BBMemoryError :: ME.MemoryError sym -> BadBehavior sym + deriving Typeable + +concBadBehavior :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + BadBehavior sym -> IO (BadBehavior sym) +concBadBehavior sym conc (BBUndefinedBehavior ub) = + BBUndefinedBehavior <$> UB.concUB sym conc ub +concBadBehavior sym conc (BBMemoryError me) = + BBMemoryError <$> ME.concMemoryError sym conc me + +-- ----------------------------------------------------------------------- +-- ** LLVMSafetyAssertion + +data LLVMSafetyAssertion sym = + LLVMSafetyAssertion + { _classifier :: BadBehavior sym -- ^ What could have gone wrong? + , _predicate :: Pred sym -- ^ Is the value safe/defined? + , _extra :: Maybe Text -- ^ Additional human-readable context + } + deriving (Generic, Typeable) + +-- ----------------------------------------------------------------------- +-- ** Constructors + +-- We expose these rather than the constructors to retain the freedom to +-- change the internal representation. + +undefinedBehavior' :: UB.UndefinedBehavior (RegValue' sym) + -> Pred sym + -> Text + -> LLVMSafetyAssertion sym +undefinedBehavior' ub pred expl = + LLVMSafetyAssertion (BBUndefinedBehavior ub) pred (Just expl) + +undefinedBehavior :: UB.UndefinedBehavior (RegValue' sym) + -> Pred sym + -> LLVMSafetyAssertion sym +undefinedBehavior ub pred = + LLVMSafetyAssertion (BBUndefinedBehavior ub) pred Nothing + +memoryError :: (1 <= w) => ME.MemoryOp sym w -> ME.MemoryErrorReason -> Pred sym -> LLVMSafetyAssertion sym +memoryError mop rsn pred = + LLVMSafetyAssertion (BBMemoryError (ME.MemoryError mop rsn)) pred Nothing + +poison' :: Poison.Poison (RegValue' sym) + -> Pred sym + -> Text + -> LLVMSafetyAssertion sym +poison' poison_ pred expl = + LLVMSafetyAssertion (BBUndefinedBehavior (UB.PoisonValueCreated poison_)) pred (Just expl) + +poison :: Poison.Poison (RegValue' sym) + -> Pred sym + -> LLVMSafetyAssertion sym +poison poison_ pred = + LLVMSafetyAssertion (BBUndefinedBehavior (UB.PoisonValueCreated poison_)) pred Nothing + +-- ----------------------------------------------------------------------- +-- ** Lenses + +classifier :: Simple Lens (LLVMSafetyAssertion sym) (BadBehavior sym) +classifier = lens _classifier (\s v -> s { _classifier = v}) + +predicate :: Simple Lens (LLVMSafetyAssertion sym) (Pred sym) +predicate = lens _predicate (\s v -> s { _predicate = v}) + +extra :: Simple Lens (LLVMSafetyAssertion sym) (Maybe Text) +extra = lens _extra (\s v -> s { _extra = v}) + +explainBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann +explainBB = \case + BBUndefinedBehavior ub -> UB.explain ub + BBMemoryError me -> ME.explain me + +detailBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann +detailBB = \case + BBUndefinedBehavior ub -> UB.ppDetails ub + BBMemoryError me -> ME.details me + +ppBB :: IsExpr (SymExpr sym) => BadBehavior sym -> Doc ann +ppBB = \case + BBUndefinedBehavior ub -> UB.ppDetails ub + BBMemoryError me -> ME.ppMemoryError me diff --git a/src/Lang/Crucible/LLVM/Errors/MemoryError.hs b/src/Lang/Crucible/LLVM/Errors/MemoryError.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Errors/MemoryError.hs @@ -0,0 +1,260 @@ +-- | +-- Module : Lang.Crucible.LLVM.Errors.MemoryError +-- Description : Errors that arise when reading and writing memory +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module Lang.Crucible.LLVM.Errors.MemoryError +( MemoryError(..) +, MemErrContext +, explain +, details +, ppMemoryError +, MemoryOp(..) +, memOpMem +, ppMemoryOp +, MemoryErrorReason(..) +, ppMemoryErrorReason +, FuncLookupError(..) +, ppFuncLookupError + +, concMemoryError +, concMemoryOp +) where + +import Prelude hiding (pred) + +import Data.Text (Text) +import qualified Text.LLVM.AST as L +import Type.Reflection (SomeTypeRep(SomeTypeRep)) +import Prettyprinter + +import What4.Interface +import What4.Expr (GroundValue) + +import Lang.Crucible.LLVM.MemModel.Pointer (LLVMPtr, concBV) +import Lang.Crucible.LLVM.MemModel.Common +import Lang.Crucible.LLVM.MemModel.Type +import Lang.Crucible.LLVM.MemModel.MemLog +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP + +data MemoryOp sym w + = MemLoadOp StorageType (Maybe String) (LLVMPtr sym w) (Mem sym) + | MemStoreOp StorageType (Maybe String) (LLVMPtr sym w) (Mem sym) + | MemStoreBytesOp (Maybe String) (LLVMPtr sym w) (Maybe (SymBV sym w)) (Mem sym) + | forall wlen. (1 <= wlen) => MemCopyOp + (Maybe String, LLVMPtr sym w) -- dest + (Maybe String, LLVMPtr sym w) -- src + (SymBV sym wlen) -- length + (Mem sym) + | MemLoadHandleOp (Maybe L.Type) (Maybe String) (LLVMPtr sym w) (Mem sym) + | forall wlen. (1 <= wlen) => MemInvalidateOp + Text (Maybe String) (LLVMPtr sym w) (SymBV sym wlen) (Mem sym) + +memOpMem :: MemoryOp sym w -> Mem sym +memOpMem = + \case + MemLoadOp _ _ _ mem -> mem + MemStoreOp _ _ _ mem -> mem + MemStoreBytesOp _ _ _ mem -> mem + MemCopyOp _ _ _ mem -> mem + MemLoadHandleOp _ _ _ mem -> mem + MemInvalidateOp _ _ _ _ mem -> mem + +data MemoryError sym where + MemoryError :: (1 <= w) => + MemoryOp sym w -> + MemoryErrorReason -> + MemoryError sym + +-- | The kinds of type errors that arise while reading memory/constructing LLVM +-- values +data MemoryErrorReason = + TypeMismatch StorageType StorageType + | UnexpectedArgumentType Text [StorageType] + | ApplyViewFail ValueView + | Invalid StorageType + | Invalidated Text + | NoSatisfyingWrite StorageType + | UnwritableRegion + | UnreadableRegion + | BadFunctionPointer FuncLookupError + | OverlappingRegions + deriving (Eq, Ord) + +-- | Reasons that looking up a function handle associated with an LLVM pointer +-- may fail +data FuncLookupError + = SymbolicPointer + | RawBitvector + | NoOverride + | Uncallable SomeTypeRep + deriving (Eq, Ord) + +ppFuncLookupError :: FuncLookupError -> Doc ann +ppFuncLookupError = + \case + SymbolicPointer -> "Cannot resolve a symbolic pointer to a function handle" + RawBitvector -> "Cannot treat raw bitvector as function pointer" + NoOverride -> "No implementation or override found for pointer" + Uncallable (SomeTypeRep typeRep) -> + vsep [ "Data associated with the pointer found, but was not a callable function:" + , hang 2 (viaShow typeRep) + ] + +type MemErrContext sym w = MemoryOp sym w + +ppGSym :: Maybe String -> [Doc ann] +ppGSym Nothing = [] +ppGSym (Just nm) = [ "Global symbol", viaShow nm ] + +ppMemoryOp :: IsExpr (SymExpr sym) => MemoryOp sym w -> Doc ann +ppMemoryOp (MemLoadOp tp gsym ptr mem) = + vsep [ "Performing overall load at type:" <+> ppType tp + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemStoreOp tp gsym ptr mem) = + vsep [ "Performing store at type:" <+> ppType tp + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemStoreBytesOp gsym ptr Nothing mem) = + vsep [ "Performing byte array store for entire address space" + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemStoreBytesOp gsym ptr (Just len) mem) = + vsep [ "Performing byte array store of length:" <+> printSymExpr len + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemCopyOp (gsym_dest, dest) (gsym_src, src) len mem) = + vsep [ "Performing a memory copy of" <+> printSymExpr len <+> "bytes" + , indent 2 (hsep ([ "Destination:" ] ++ ppGSym gsym_dest ++ [ ppPtr dest ])) + , indent 2 (hsep ([ "Source: " ] ++ ppGSym gsym_src ++ [ ppPtr src ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemLoadHandleOp sig gsym ptr mem) = + vsep [ case sig of + Just s -> + hsep ["Attempting to load callable function with type:", viaShow (LPP.ppType s)] + Nothing -> + hsep ["Attempting to load callable function:"] + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +ppMemoryOp (MemInvalidateOp msg gsym ptr len mem) = + vsep [ "Performing explicit memory invalidation of" <+> printSymExpr len <+> "bytes" + , pretty msg + , indent 2 (hsep ([ "Via pointer:" ] ++ ppGSym gsym ++ [ ppPtr ptr ])) + , "In memory state:" + , indent 2 (ppMem mem) + ] + +explain :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann +explain (MemoryError _mop rsn) = ppMemoryErrorReason rsn + +details :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann +details (MemoryError mop _rsn) = ppMemoryOp mop + +ppMemoryError :: IsExpr (SymExpr sym) => MemoryError sym -> Doc ann +ppMemoryError (MemoryError mop rsn) = vcat [ppMemoryErrorReason rsn, ppMemoryOp mop] + +ppMemoryErrorReason :: MemoryErrorReason -> Doc ann +ppMemoryErrorReason = + \case + TypeMismatch ty1 ty2 -> + vcat + [ "Type mismatch: " + , indent 2 (vcat [ ppType ty1 + , ppType ty2 + ]) + ] + UnexpectedArgumentType txt vals -> + vcat + [ "Unexpected argument type:" + , pretty txt + , indent 2 (vcat (map viaShow vals)) + ] + ApplyViewFail vw -> + "Failure when applying value view" <+> viaShow vw + Invalid ty -> + "Load from invalid memory at type" <+> ppType ty + Invalidated msg -> + "Load from explicitly invalidated memory:" <+> pretty msg + NoSatisfyingWrite tp -> + vcat + [ "No previous write to this location was found" + , indent 2 ("Attempting load at type:" <+> ppType tp) + ] + UnwritableRegion -> + "The region wasn't allocated, wasn't large enough, or was marked as readonly" + UnreadableRegion -> + "The region wasn't allocated or wasn't large enough" + BadFunctionPointer err -> + vcat + [ "The given pointer could not be resolved to a callable function" + , ppFuncLookupError err + ] + OverlappingRegions -> + "Memory regions required to be disjoint" + +concMemoryError :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemoryError sym -> IO (MemoryError sym) +concMemoryError sym conc (MemoryError mop rsn) = + MemoryError <$> concMemoryOp sym conc mop <*> pure rsn + +concMemoryOp :: + (1 <= w, IsExprBuilder sym) => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemoryOp sym w -> IO (MemoryOp sym w) +concMemoryOp sym conc (MemLoadOp tp gsym ptr mem) = + MemLoadOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem +concMemoryOp sym conc (MemStoreOp tp gsym ptr mem) = + MemStoreOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem +concMemoryOp sym conc (MemStoreBytesOp gsym ptr len mem) = + MemStoreBytesOp gsym <$> + concPtr sym conc ptr <*> + traverse (concBV sym conc) len <*> + concMem sym conc mem +concMemoryOp sym conc (MemLoadHandleOp tp gsym ptr mem) = + MemLoadHandleOp tp gsym <$> concPtr sym conc ptr <*> concMem sym conc mem +concMemoryOp sym conc (MemCopyOp (gsym_dest, dest) (gsym_src, src) len mem) = + do dest' <- concPtr sym conc dest + src' <- concPtr sym conc src + len' <- concBV sym conc len + mem' <- concMem sym conc mem + pure (MemCopyOp (gsym_dest, dest') (gsym_src, src') len' mem') +concMemoryOp sym conc (MemInvalidateOp msg gsym ptr len mem) = + MemInvalidateOp msg gsym <$> + concPtr sym conc ptr <*> + concBV sym conc len <*> + concMem sym conc mem diff --git a/src/Lang/Crucible/LLVM/Errors/Poison.hs b/src/Lang/Crucible/LLVM/Errors/Poison.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Errors/Poison.hs @@ -0,0 +1,398 @@ +-- | +-- Module : Lang.Crucible.LLVM.Errors.Poison +-- Description : All about LLVM poison values +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-- This module is intended to be imported qualified. +-- +-- Undefined values follow control flow, wereas the poison values follow data +-- flow. See the module-level comment in "Lang.Crucible.LLVM.Translation". +-- +-- This email provides an explanation and motivation for poison and @undef@ +-- values: https://lists.llvm.org/pipermail/llvm-dev/2016-October/106182.html +-------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Errors.Poison + ( Poison(..) + , cite + , explain + , standard + , details + , pp + , ppReg + , concPoison + ) where + +import Data.Kind (Type) +import Data.Maybe (isJust) +import Data.Typeable (Typeable) +import Prettyprinter + +import qualified Data.Parameterized.TraversableF as TF +import Data.Parameterized.TraversableF (FunctorF(..), FoldableF(..), TraversableF(..)) +import qualified Data.Parameterized.TH.GADT as U +import Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..)) +import Data.Parameterized.Classes (OrderingF(..), toOrdering) + +import Lang.Crucible.LLVM.Errors.Standards +import Lang.Crucible.LLVM.MemModel.Pointer (LLVMPointerType, concBV, concPtr', ppPtr) +import Lang.Crucible.Simulator.RegValue (RegValue'(..)) +import Lang.Crucible.Types +import qualified What4.Interface as W4I +import What4.Expr (GroundValue) + +data Poison (e :: CrucibleType -> Type) where + -- | Arguments: @op1@, @op2@ + AddNoUnsignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + AddNoSignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + SubNoUnsignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + SubNoSignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + MulNoUnsignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + MulNoSignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + UDivExact :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + SDivExact :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + ShlOp2Big :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + ShlNoUnsignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + ShlNoSignedWrap :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + LshrExact :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + LshrOp2Big :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + AshrExact :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | Arguments: @op1@, @op2@ + AshrOp2Big :: (1 <= w) => e (BVType w) + -> e (BVType w) + -> Poison e + -- | TODO(langston): store the 'Vector' + ExtractElementIndex :: (1 <= w) => e (BVType w) + -> Poison e + -- | TODO(langston): store the 'Vector' + InsertElementIndex :: (1 <= w) => e (BVType w) + -> Poison e + LLVMAbsIntMin :: (1 <= w) => e (BVType w) + -> Poison e + GEPOutOfBounds :: (1 <= w, 1 <= wptr) => e (LLVMPointerType wptr) + -> e (BVType w) + -> Poison e + deriving (Typeable) + +standard :: Poison e -> Standard +standard = + \case + AddNoUnsignedWrap _ _ -> LLVMRef LLVM8 + AddNoSignedWrap _ _ -> LLVMRef LLVM8 + SubNoUnsignedWrap _ _ -> LLVMRef LLVM8 + SubNoSignedWrap _ _ -> LLVMRef LLVM8 + MulNoUnsignedWrap _ _ -> LLVMRef LLVM8 + MulNoSignedWrap _ _ -> LLVMRef LLVM8 + UDivExact _ _ -> LLVMRef LLVM8 + SDivExact _ _ -> LLVMRef LLVM8 + ShlOp2Big _ _ -> LLVMRef LLVM8 + ShlNoUnsignedWrap _ _ -> LLVMRef LLVM8 + ShlNoSignedWrap _ _ -> LLVMRef LLVM8 + LshrExact _ _ -> LLVMRef LLVM8 + LshrOp2Big _ _ -> LLVMRef LLVM8 + AshrExact _ _ -> LLVMRef LLVM8 + AshrOp2Big _ _ -> LLVMRef LLVM8 + ExtractElementIndex _ -> LLVMRef LLVM8 + InsertElementIndex _ -> LLVMRef LLVM8 + LLVMAbsIntMin _ -> LLVMRef LLVM12 + GEPOutOfBounds _ _ -> LLVMRef LLVM8 + +-- | Which section(s) of the document state that this is poison? +cite :: Poison e -> Doc ann +cite = + \case + AddNoUnsignedWrap _ _ -> "‘add’ Instruction (Semantics)" + AddNoSignedWrap _ _ -> "‘add’ Instruction (Semantics)" + SubNoUnsignedWrap _ _ -> "‘sub’ Instruction (Semantics)" + SubNoSignedWrap _ _ -> "‘sub’ Instruction (Semantics)" + MulNoUnsignedWrap _ _ -> "‘mul’ Instruction (Semantics)" + MulNoSignedWrap _ _ -> "‘mul’ Instruction (Semantics)" + UDivExact _ _ -> "‘udiv’ Instruction (Semantics)" + SDivExact _ _ -> "‘sdiv’ Instruction (Semantics)" + ShlOp2Big _ _ -> "‘shl’ Instruction (Semantics)" + ShlNoUnsignedWrap _ _ -> "‘shl’ Instruction (Semantics)" + ShlNoSignedWrap _ _ -> "‘shl’ Instruction (Semantics)" + LshrExact _ _ -> "‘lshr’ Instruction (Semantics)" + LshrOp2Big _ _ -> "‘lshr’ Instruction (Semantics)" + AshrExact _ _ -> "‘ashr’ Instruction (Semantics)" + AshrOp2Big _ _ -> "‘ashr’ Instruction (Semantics)" + ExtractElementIndex _ -> "‘extractelement’ Instruction (Semantics)" + InsertElementIndex _ -> "‘insertelement’ Instruction (Semantics)" + LLVMAbsIntMin _ -> "‘llvm.abs.*’ Intrinsic (Semantics)" + GEPOutOfBounds _ _ -> "‘getelementptr’ Instruction (Semantics)" + +explain :: Poison e -> Doc ann +explain = + \case + AddNoUnsignedWrap _ _ -> + "Unsigned addition caused wrapping even though the `nuw` flag was set" + AddNoSignedWrap _ _ -> + "Signed addition caused wrapping even though the `nsw` flag was set" + SubNoUnsignedWrap _ _ -> + "Unsigned subtraction caused wrapping even though the `nuw` flag was set" + SubNoSignedWrap _ _ -> + "Signed subtraction caused wrapping even though the `nsw` flag was set" + MulNoUnsignedWrap _ _ -> + "Unsigned multiplication caused wrapping even though the `nuw` flag was set" + MulNoSignedWrap _ _ -> + "Signed multiplication caused wrapping even though the `nsw` flag was set" + SDivExact _ _ -> + "Inexact signed division even though the `exact` flag was set" + UDivExact _ _ -> + "Inexact unsigned division even though the `exact` flag was set" + ShlOp2Big _ _ -> + "The second operand of `shl` was equal to or greater than the number of bits in the first operand" + ShlNoUnsignedWrap _ _ -> + "Left shift shifted out non-zero bits even though the `nuw` flag was set" + ShlNoSignedWrap _ _ -> + "Left shift shifted out some bits that disagreed with the sign bit even though the `nsw` flag was set" + LshrExact _ _ -> + "Inexact `lshr` (logical right shift) result even though the `exact` flag was set" + LshrOp2Big _ _ -> + "The second operand of `lshr` was equal to or greater than the number of bits in the first operand" + AshrExact _ _ -> + "Inexact `ashr` (arithmetic right shift) result even though the `exact` flag was set" + AshrOp2Big _ _ -> + "The second operand of `ashr` was equal to or greater than the number of bits in the first operand" + ExtractElementIndex _ -> cat $ + [ "Attempted to extract an element from a vector at an index that was" + , "greater than the length of the vector" + ] + InsertElementIndex _ -> cat $ + [ "Attempted to insert an element into a vector at an index that was" + , "greater than the length of the vector" + ] + LLVMAbsIntMin _ -> cat $ + [ "The first argument of `llvm.abs.*` was `INT_MIN` even though the" + , "second argument was `1`" + ] + + -- The following explanation is a bit unsatisfactory, because it is specific + -- to how we treat this instruction in Crucible. + GEPOutOfBounds _ _ -> cat $ + [ "Calling `getelementptr` resulted in an index that was out of bounds for the" + , "given allocation (likely due to arithmetic overflow), but Crucible currently" + , "treats all GEP instructions as if they had the `inbounds` flag set." + ] + +details :: forall sym ann. + W4I.IsExpr (W4I.SymExpr sym) => Poison (RegValue' sym) -> [Doc ann] +details = + \case + AddNoUnsignedWrap v1 v2 -> args [v1, v2] + AddNoSignedWrap v1 v2 -> args [v1, v2] + SubNoUnsignedWrap v1 v2 -> args [v1, v2] + SubNoSignedWrap v1 v2 -> args [v1, v2] + MulNoUnsignedWrap v1 v2 -> args [v1, v2] + MulNoSignedWrap v1 v2 -> args [v1, v2] + SDivExact v1 v2 -> args [v1, v2] + UDivExact v1 v2 -> args [v1, v2] + ShlOp2Big v1 v2 -> args [v1, v2] + ShlNoUnsignedWrap v1 v2 -> args [v1, v2] + ShlNoSignedWrap v1 v2 -> args [v1, v2] + LshrExact v1 v2 -> args [v1, v2] + LshrOp2Big v1 v2 -> args [v1, v2] + AshrExact v1 v2 -> args [v1, v2] + AshrOp2Big v1 v2 -> args [v1, v2] + ExtractElementIndex v -> args [v] + InsertElementIndex v -> args [v] + LLVMAbsIntMin v -> args [v] + GEPOutOfBounds (RV ptr) (RV bv) -> + [ "Pointer:" <+> ppPtr ptr + , "Bitvector:" <+> W4I.printSymExpr bv + ] + + where + args :: forall w. [RegValue' sym (BVType w)] -> [Doc ann] + args [] = [ "No arguments" ] + args [RV v] = [ "Argument:" <+> W4I.printSymExpr v ] + args vs = [ hsep ("Arguments:" : map (W4I.printSymExpr . unRV) vs) ] + + +-- | Pretty print an error message relating to LLVM poison values, +-- when given a printer to produce a detailed message. +pp :: (Poison e -> [Doc ann]) -> Poison e -> Doc ann +pp extra poison = vcat $ + [ "Poison value encountered: " + , explain poison + , vcat (extra poison) + , cat [ "Reference: " + , pretty (ppStd (standard poison)) + , cite poison + ] + ] ++ case stdURL (standard poison) of + Just url -> ["Document URL:" <+> pretty url] + Nothing -> [] + +-- | Pretty print an error message relating to LLVM poison values +ppReg ::W4I.IsExpr (W4I.SymExpr sym) => Poison (RegValue' sym) -> Doc ann +ppReg = pp details + +-- | Concretize a poison error message. +concPoison :: forall sym. + W4I.IsExprBuilder sym => + sym -> + (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) -> + Poison (RegValue' sym) -> IO (Poison (RegValue' sym)) +concPoison sym conc poison = + let bv :: forall w. (1 <= w) => RegValue' sym (BVType w) -> IO (RegValue' sym (BVType w)) + bv (RV x) = RV <$> concBV sym conc x in + case poison of + AddNoUnsignedWrap v1 v2 -> + AddNoUnsignedWrap <$> bv v1 <*> bv v2 + AddNoSignedWrap v1 v2 -> + AddNoSignedWrap <$> bv v1 <*> bv v2 + SubNoUnsignedWrap v1 v2 -> + SubNoUnsignedWrap <$> bv v1 <*> bv v2 + SubNoSignedWrap v1 v2 -> + SubNoSignedWrap <$> bv v1 <*> bv v2 + MulNoUnsignedWrap v1 v2 -> + MulNoUnsignedWrap<$> bv v1 <*> bv v2 + MulNoSignedWrap v1 v2 -> + MulNoSignedWrap <$> bv v1 <*> bv v2 + UDivExact v1 v2 -> + UDivExact <$> bv v1 <*> bv v2 + SDivExact v1 v2 -> + SDivExact <$> bv v1 <*> bv v2 + ShlOp2Big v1 v2 -> + ShlOp2Big <$> bv v1 <*> bv v2 + ShlNoUnsignedWrap v1 v2 -> + ShlNoUnsignedWrap <$> bv v1 <*> bv v2 + ShlNoSignedWrap v1 v2 -> + ShlNoSignedWrap <$> bv v1 <*> bv v2 + LshrExact v1 v2 -> + LshrExact <$> bv v1 <*> bv v2 + LshrOp2Big v1 v2 -> + LshrOp2Big <$> bv v1 <*> bv v2 + AshrExact v1 v2 -> + AshrExact <$> bv v1 <*> bv v2 + AshrOp2Big v1 v2 -> + AshrOp2Big <$> bv v1 <*> bv v2 + ExtractElementIndex v -> + ExtractElementIndex <$> bv v + InsertElementIndex v -> + InsertElementIndex <$> bv v + GEPOutOfBounds p v -> + GEPOutOfBounds <$> concPtr' sym conc p <*> bv v + LLVMAbsIntMin v -> + LLVMAbsIntMin <$> bv v + + +-- ----------------------------------------------------------------------- +-- ** Instances + +-- The weirdness in these instances is due to existential quantification over +-- the width. We have to make sure the type variable doesn't escape its scope. + +$(return []) + +eqcPoison :: forall e. + (forall t1 t2. e t1 -> e t2 -> Maybe (t1 :~: t2)) -> + Poison e -> Poison e -> Maybe (() :~: ()) +eqcPoison subterms = + let subterms' :: forall p q. e p -> e q -> Maybe (() :~: ()) + subterms' a b = + case subterms a b of + Just Refl -> Just Refl + Nothing -> Nothing + in $(U.structuralTypeEquality [t|Poison|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |]) + ]) + +ordcPoison :: forall e f. + (forall t1 t2. e t1 -> f t2 -> OrderingF t1 t2) -> + Poison e -> Poison f -> OrderingF () () +ordcPoison subterms = + let subterms' :: forall p q. e p -> f q -> OrderingF () () + subterms' a b = + case subterms a b of + EQF -> (EQF :: OrderingF () ()) + GTF -> (GTF :: OrderingF () ()) + LTF -> (LTF :: OrderingF () ()) + + in $(U.structuralTypeOrd [t|Poison|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType, [| subterms' |]) + ]) + +instance TestEqualityC Poison where + testEqualityC subterms x y = isJust $ eqcPoison subterms x y + +instance OrdC Poison where + compareC subterms x y = toOrdering $ ordcPoison subterms x y + +instance FunctorF Poison where + fmapF = TF.fmapFDefault + +instance FoldableF Poison where + foldMapF = TF.foldMapFDefault + +instance TraversableF Poison where + traverseF :: forall m e f. Applicative m + => (forall s. e s -> m (f s)) + -> Poison e + -> m (Poison f) + traverseF = + $(U.structuralTraversal [t|Poison|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType + , [| ($) |] -- \f x -> f x + ) + ] + ) diff --git a/src/Lang/Crucible/LLVM/Errors/Standards.hs b/src/Lang/Crucible/LLVM/Errors/Standards.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Errors/Standards.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Lang.Crucible.LLVM.Errors.Standards +-- Description : Standards documents +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-------------------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE Safe #-} + +module Lang.Crucible.LLVM.Errors.Standards + ( Standard(..) + , CStdVer(..) + , CXXStdVer(..) + , LLVMRefVer(..) + , ppStd + , stdURL + ) where + +import Prelude hiding (unwords, unlines) + +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import Data.Text (Text, pack) + +-- | The various standards that prohibit certain behaviors +data Standard = + CStd CStdVer -- ^ The C language standard + | CXXStd CXXStdVer -- ^ The C++ language standard + | LLVMRef LLVMRefVer -- ^ The LLVM language reference + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +-- | Versions of the C standard +data CStdVer = + C99 + | C11 + | C18 + deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable) + +-- | Versions of the C++ standard +data CXXStdVer = + CXX03 + | CXX11 + | CXX14 + | CXX17 + deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable) + +ppCXXStdVer :: CXXStdVer -> Text +ppCXXStdVer CXX03 = "C++03" +ppCXXStdVer CXX11 = "C++11" +ppCXXStdVer CXX14 = "C++14" +ppCXXStdVer CXX17 = "C++17" + +-- | Versions of the LLVM Language Reference +data LLVMRefVer = + LLVM38 + | LLVM4 + | LLVM5 + | LLVM6 + | LLVM7 + | LLVM8 + | LLVM12 + deriving (Data, Eq, Enum, Generic, Ord, Read, Show, Typeable) + +ppLLVMRefVer :: LLVMRefVer -> Text +ppLLVMRefVer LLVM38 = "3.8" +ppLLVMRefVer LLVM4 = "4" +ppLLVMRefVer LLVM5 = "5" +ppLLVMRefVer LLVM6 = "6" +ppLLVMRefVer LLVM7 = "7" +ppLLVMRefVer LLVM8 = "8" +ppLLVMRefVer LLVM12 = "12" + +stdURL :: Standard -> Maybe Text +stdURL (CStd C11) = Just "http://www.iso-9899.info/n1570.html" +stdURL (CXXStd CXX17) = Just "http://www.open-std.org/jtc1/sc22/wg14/www/abq/c17_updated_proposed_fdis.pdf" +stdURL (LLVMRef LLVM38) = Just "https://releases.llvm.org/3.8.0/docs/LangRef.html" +stdURL (LLVMRef LLVM4) = Just "https://releases.llvm.org/4.0.1/docs/LangRef.html" +stdURL (LLVMRef LLVM5) = Just "https://releases.llvm.org/5.0.0/docs/LangRef.html" +stdURL (LLVMRef LLVM6) = Just "https://releases.llvm.org/6.0.0/docs/LangRef.html" +stdURL (LLVMRef LLVM7) = Just "https://releases.llvm.org/7.0.0/docs/LangRef.html" +stdURL (LLVMRef LLVM8) = Just "https://releases.llvm.org/8.0.0/docs/LangRef.html" +stdURL (LLVMRef LLVM12) = Just "https://releases.llvm.org/12.0.0/docs/LangRef.html" +stdURL _ = Nothing + +ppStd :: Standard -> Text +ppStd = + \case + CStd ver -> "The C language standard, version " <> pack (show ver) + CXXStd ver -> "The C++ language standard, version " <> ppCXXStdVer ver + LLVMRef ver -> "The LLVM language reference, version " <> ppLLVMRefVer ver diff --git a/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs b/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Errors/UndefinedBehavior.hs @@ -0,0 +1,615 @@ +-- | +-- Module : Lang.Crucible.LLVM.Errors.UndefinedBehavior +-- Description : All about undefined behavior +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-- This module is intended to be imported qualified. +-- +-- This module serves as an ad-hoc reference for the sort of undefined behaviors +-- that the Crucible LLVM memory model is aware of. The information contained +-- here is used in +-- * providing helpful error messages +-- * configuring which safety checks to perform +-- +-- Disabling checks for undefined behavior does not change the behavior of any +-- memory operations. If it is used to enable the simulation of undefined +-- behavior, the result is that any guarantees that Crucible provides about the +-- code essentially have an additional hypothesis: that the LLVM +-- compiler/hardware platform behave identically to Crucible's simulator when +-- encountering such behavior. +-------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Errors.UndefinedBehavior + ( + -- ** Undefined Behavior + PtrComparisonOperator(..) + , UndefinedBehavior(..) + , cite + , details + , explain + , ppDetails + , ppCitation + , pp + + , concUB + ) where + +import Prelude + +import GHC.Generics (Generic) +import Data.Data (Data) +import Data.Kind (Type) +import Data.Maybe (isJust) +import Data.Typeable (Typeable) +import Prettyprinter + +import Data.Parameterized.Classes (toOrdering, fromOrdering) +import Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..)) +import qualified Data.Parameterized.TH.GADT as U +import Data.Parameterized.TraversableF (FunctorF(..), FoldableF(..), TraversableF(..)) +import qualified Data.Parameterized.TraversableF as TF + +import qualified What4.Interface as W4I +import What4.Expr (GroundValue) + +import Lang.Crucible.Types +import Lang.Crucible.Simulator.RegValue (RegValue'(..)) +import Lang.Crucible.LLVM.DataLayout (Alignment, fromAlignment) +import Lang.Crucible.LLVM.Errors.Standards +import qualified Lang.Crucible.LLVM.Errors.Poison as Poison +import Lang.Crucible.LLVM.MemModel.Pointer (ppPtr, concBV, concPtr') +import Lang.Crucible.LLVM.MemModel.Type (StorageType) +import Lang.Crucible.LLVM.Types (LLVMPointerType) + +-- ----------------------------------------------------------------------- +-- ** UndefinedBehavior + +-- | The various comparison operators you can use on pointers +data PtrComparisonOperator = + Eq + | Leq + deriving (Data, Eq, Generic, Enum, Ord, Read, Show) + +ppPtrComparison :: PtrComparisonOperator -> Doc ann +ppPtrComparison Eq = "Equality comparison (==)" +ppPtrComparison Leq = "Ordering comparison (<=)" + +-- | This type is parameterized on a higher-kinded term constructor so that it +-- can be instantiated for expressions at translation time (i.e. the 'Expr' in +-- 'LLVMGenerator'), or for expressions at runtime ('SymExpr'). +-- +-- See 'cite' and 'explain' for what each constructor means at the C/LLVM level. +-- +-- The commented-out constructors correspond to behaviors that don't have +-- explicit checks yet (but probably should!). +data UndefinedBehavior (e :: CrucibleType -> Type) where + + -- -------------------------------- Memory management + + FreeBadOffset :: + (1 <= w) => + e (LLVMPointerType w) -> + UndefinedBehavior e + + FreeUnallocated :: + (1 <= w) => + e (LLVMPointerType w) -> + UndefinedBehavior e + + DoubleFree :: + (1 <= w) => + e (LLVMPointerType w) -> + UndefinedBehavior e + + -- | Arguments: Destination pointer, fill byte, length + MemsetInvalidRegion :: + (1 <= w, 1 <= v) => + e (LLVMPointerType w) -> + e (BVType 8) -> + e (BVType v) -> + UndefinedBehavior e + + -- | Arguments: Read destination, alignment + ReadBadAlignment :: + (1 <= w) => + e (LLVMPointerType w) -> + Alignment -> + UndefinedBehavior e + + -- | Arguments: Write destination, alignment + WriteBadAlignment :: + (1 <= w) => + e (LLVMPointerType w) -> + Alignment -> + UndefinedBehavior e + + -- -------------------------------- Pointer arithmetic + + PtrAddOffsetOutOfBounds :: + (1 <= w) => + e (LLVMPointerType w) -> + e (BVType w) -> + UndefinedBehavior e + + -- | Arguments: kind of comparison, the invalid pointer, the other pointer + CompareInvalidPointer :: + (1 <= w) => + PtrComparisonOperator -> + e (LLVMPointerType w) -> + e (LLVMPointerType w) -> + UndefinedBehavior e + + -- | "In all other cases, the behavior is undefined" + -- TODO: 'PtrComparisonOperator' argument? + CompareDifferentAllocs :: + (1 <= w) => + e (LLVMPointerType w) -> + e (LLVMPointerType w) -> + UndefinedBehavior e + + -- | "When two pointers are subtracted, both shall point to elements of the + -- same array object" + PtrSubDifferentAllocs :: + (1 <= w) => + e (LLVMPointerType w) -> + e (LLVMPointerType w) -> + UndefinedBehavior e + + -- | Pointer cast to an integer type other than + -- pointer width integers + PointerIntCast :: + (1 <= w) => + e (LLVMPointerType w) -> + StorageType -> + UndefinedBehavior e + + -- | Pointer used in an unsupported arithmetic or bitvector operation + PointerUnsupportedOp :: + (1 <= w) => + e (LLVMPointerType w) -> + String -> + UndefinedBehavior e + + -- | Pointer cast to a floating-point type + PointerFloatCast :: + (1 <= w) => + e (LLVMPointerType w) -> + StorageType -> + UndefinedBehavior e + + -- | "One of the following shall hold: [...] one operand is a pointer and the + -- other is a null pointer constant." + ComparePointerToBV :: + (1 <= w) => + e (LLVMPointerType w) -> + e (BVType w) -> + UndefinedBehavior e + + -------------------------------- Division operators + + -- | @SymBV@ or @Expr _ _ (BVType w)@ + UDivByZero :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + SDivByZero :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + URemByZero :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + SRemByZero :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + SDivOverflow :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + SRemOverflow :: (1 <= w) => e (BVType w) -> e (BVType w) -> UndefinedBehavior e + + -------------------------------- Integer arithmetic + + AbsIntMin :: (1 <= w) => e (BVType w) -> UndefinedBehavior e + + PoisonValueCreated :: + Poison.Poison e -> + UndefinedBehavior e + + {- + MemcpyDisjoint :: UndefinedBehavior e + DereferenceBadAlignment :: UndefinedBehavior e + ModifiedStringLiteral :: UndefinedBehavior e + -} + deriving (Typeable) + +-- | Which document prohibits this behavior? +standard :: UndefinedBehavior e -> Standard +standard = + \case + + -- -------------------------------- Memory management + + DoubleFree{} -> CStd C11 + FreeBadOffset{} -> CStd C11 + FreeUnallocated{} -> CStd C11 + MemsetInvalidRegion{} -> CStd C11 + ReadBadAlignment{} -> CStd C11 + WriteBadAlignment{} -> CStd C11 + + -- -------------------------------- Pointer arithmetic + + PtrAddOffsetOutOfBounds{} -> CStd C11 + CompareInvalidPointer{} -> CStd C11 + CompareDifferentAllocs{} -> CStd C11 + PtrSubDifferentAllocs{} -> CStd C11 + ComparePointerToBV{} -> CStd C11 + PointerFloatCast{} -> CStd C11 + PointerIntCast{} -> CStd C11 + PointerUnsupportedOp{} -> CStd C11 + + -- -------------------------------- Division operators + + UDivByZero{} -> CStd C11 + SDivByZero{} -> CStd C11 + URemByZero{} -> CStd C11 + SRemByZero{} -> CStd C11 + SDivOverflow{} -> CStd C11 + SRemOverflow{} -> CStd C11 + + -- -------------------------------- Integer arithmetic + + AbsIntMin{} -> CStd C11 + + PoisonValueCreated p -> Poison.standard p + + {- + MemcpyDisjoint -> CStd C11 + DereferenceBadAlignment -> CStd C11 + ModifiedStringLiteral -> CStd C11 + -} + +-- | Which section(s) of the document prohibit this behavior? +cite :: UndefinedBehavior e -> Doc ann +cite = + \case + + -------------------------------- Memory management + + FreeBadOffset{} -> "§7.22.3.3 The free function, ¶2" + FreeUnallocated{} -> "§7.22.3.3 The free function, ¶2" + DoubleFree{} -> "§7.22.3.3 The free function, ¶2" + MemsetInvalidRegion{} -> "§7.24.1 String function conventions, ¶1" + ReadBadAlignment{} -> "§6.5.3.2 Address and indirection operators, ¶4" + WriteBadAlignment{} -> "§6.5.3.2 Address and indirection operators, ¶4" + + ---------------------------------- Pointer arithmetic + + PtrAddOffsetOutOfBounds{} -> "§6.5.6 Additive operators, ¶8" + CompareInvalidPointer{} -> "§6.5.8 Relational operators, ¶5" + CompareDifferentAllocs{} -> "§6.5.8 Relational operators, ¶5" + PtrSubDifferentAllocs{} -> "§6.5.6 Additive operators, ¶9" + ComparePointerToBV{} -> "§6.5.9 Equality operators, ¶2" + PointerFloatCast{} -> "§6.5.4 Cast operators, ¶4" + PointerIntCast{} -> "§6.3.2.3 Conversions, pointers, ¶6" + PointerUnsupportedOp{} -> "§6.3.2.3 Conversions, pointers, ¶6" + + -------------------------------- Division operators + + UDivByZero{} -> "§6.5.5 Multiplicitive operators, ¶5" + SDivByZero{} -> "§6.5.5 Multiplicitive operators, ¶5" + URemByZero{} -> "§6.5.5 Multiplicitive operators, ¶5" + SRemByZero{} -> "§6.5.5 Multiplicitive operators, ¶5" + SDivOverflow{} -> "§6.5.5 Multiplicitive operators, ¶6" + SRemOverflow{} -> "§6.5.5 Multiplicitive operators, ¶6" + + -------------------------------- Integer arithmetic + + AbsIntMin{} -> "§7.22.6 Integer arithmetic functions, ¶1" + + PoisonValueCreated p -> Poison.cite p + + -------------------------------- Other + + {- + MemcpyDisjoint -> "§7.24.2.1 The memcpy function" + DereferenceBadAlignment -> "§6.5.3.2 Address and indirection operators" + ModifiedStringLiteral -> "§J.2 Undefined behavior" -- 6.4.5 + -} + +-- | What happened, and why is it a problem? +-- +-- This is a generic explanation that doesn't use the included data. +explain :: UndefinedBehavior e -> Doc ann +explain = + \case + + -- -------------------------------- Memory management + + FreeBadOffset _ -> cat $ + [ "`free` called on pointer that was not previously returned by `malloc`" + , "`calloc`, or another memory management function (the pointer did not" + , "point to the base of an allocation, its offset should be 0)" + ] + FreeUnallocated _ -> + "`free` called on pointer that didn't point to a live region of the heap" + DoubleFree{} -> "`free` called on a pointer to already-freed memory" + MemsetInvalidRegion{} -> + "Pointer passed to `memset` didn't point to a mutable allocation with enough space" + WriteBadAlignment _ _ -> + "Wrote a value into a pointer with insufficent alignment" + ReadBadAlignment _ _ -> + "Read a value from a pointer with insufficent alignment" + + -- -------------------------------- Pointer arithmetic + + PtrAddOffsetOutOfBounds _ _ -> + "Addition of an offset to a pointer resulted in a pointer to an address outside of the allocation" + CompareInvalidPointer{} -> + "Comparison of a pointer which wasn't null or a pointer to a live heap object" + CompareDifferentAllocs _ _ -> + "Comparison of pointers from different allocations" + PtrSubDifferentAllocs _ _ -> + "Subtraction of pointers from different allocations" + ComparePointerToBV _ _ -> + "Comparison of a pointer to a non zero (null) integer value" + PointerFloatCast{} -> + "Cast of a pointer to a floating-point type" + PointerIntCast{} -> + "Cast of a pointer to an incompatible integer type" + PointerUnsupportedOp{} -> + "Pointer cast to an integer used in an unsupported operation" + + -------------------------------- Division operators + + UDivByZero{} -> "Unsigned division by zero" + SDivByZero{} -> "Signed division by zero" + URemByZero{} -> "Unsigned division by zero via remainder" + SRemByZero{} -> "Signed division by zero via remainder" + SDivOverflow{} -> "Overflow during signed division" + SRemOverflow{} -> "Overflow during signed division (via signed remainder)" + + -------------------------------- Integer arithmetic + + AbsIntMin{} -> "`abs`, `labs`, or `llabs` called on `INT_MIN`" + + PoisonValueCreated p -> vcat [ "Poison value created", Poison.explain p ] + + -------------------------------- Other + + {- + MemcpyDisjoint -> "Use of `memcpy` with non-disjoint regions of memory" + DereferenceBadAlignment -> + "Dereferenced a pointer to a type with the wrong alignment" + ModifiedStringLiteral -> "Modified the underlying array of a string literal" + -} + +-- | Pretty-print the additional information held by the constructors +-- (for symbolic expressions) +details :: W4I.IsExpr (W4I.SymExpr sym) + => UndefinedBehavior (RegValue' sym) + -> [Doc ann] +details = + \case + + -------------------------------- Memory management + + FreeBadOffset ptr -> [ ppPtr1 ptr ] + FreeUnallocated ptr -> [ ppPtr1 ptr ] + DoubleFree ptr -> [ ppPtr1 ptr ] + MemsetInvalidRegion destPtr fillByte len -> + [ "Destination pointer:" <+> ppPtr1 destPtr + , "Fill byte: " <+> (W4I.printSymExpr $ unRV fillByte) + , "Length: " <+> (W4I.printSymExpr $ unRV len) + ] + WriteBadAlignment ptr alignment -> + -- TODO: replace viaShow when we have instance Pretty Bytes + [ "Required alignment:" <+> viaShow (fromAlignment alignment) <+> "bytes" + , ppPtr1 ptr + ] + ReadBadAlignment ptr alignment -> + -- TODO: replace viaShow when we have instance Pretty Bytes + [ "Required alignment:" <+> viaShow (fromAlignment alignment) <+> "bytes" + , ppPtr1 ptr + ] + + -------------------------------- Pointer arithmetic + + PtrAddOffsetOutOfBounds ptr offset -> + [ ppPtr1 ptr + , ppOffset (unRV offset) + ] + CompareInvalidPointer comparison invalid other -> + [ "Comparison: " <+> ppPtrComparison comparison + , "Invalid pointer: " <+> ppPtr (unRV invalid) + , "Other (possibly valid) pointer:" <+> ppPtr (unRV other) + ] + CompareDifferentAllocs ptr1 ptr2 -> [ ppPtr2 ptr1 ptr2 ] + PtrSubDifferentAllocs ptr1 ptr2 -> [ ppPtr2 ptr1 ptr2 ] + ComparePointerToBV ptr bv -> + [ ppPtr1 ptr + , "Bitvector:" <+> (W4I.printSymExpr $ unRV bv) + ] + PointerFloatCast ptr castType -> + [ ppPtr1 ptr + , "Cast to:" <+> viaShow castType + ] + PointerIntCast ptr castType -> + [ ppPtr1 ptr + , "Cast to:" <+> viaShow castType + ] + PointerUnsupportedOp ptr msg -> + [ ppPtr1 ptr + , pretty msg + ] + + -------------------------------- Division operators + + -- The cases are manually listed to prevent unintentional fallthrough if a + -- constructor is added. + UDivByZero v1 v2 -> [ ppBV2 v1 v2 ] + SDivByZero v1 v2 -> [ ppBV2 v1 v2 ] + URemByZero v1 v2 -> [ ppBV2 v1 v2 ] + SRemByZero v1 v2 -> [ ppBV2 v1 v2 ] + SDivOverflow v1 v2 -> [ ppBV2 v1 v2 ] + SRemOverflow v1 v2 -> [ ppBV2 v1 v2 ] + + -------------------------------- Integer arithmetic + + AbsIntMin v -> [ ppBV1 v ] + + PoisonValueCreated p -> Poison.details p + + where ppBV1 :: W4I.IsExpr (W4I.SymExpr sym) => + RegValue' sym (BVType w) -> Doc ann + ppBV1 (RV bv) = "op:" <+> W4I.printSymExpr bv + + ppBV2 :: W4I.IsExpr (W4I.SymExpr sym) => + RegValue' sym (BVType w) -> RegValue' sym (BVType w) -> Doc ann + ppBV2 (RV bv1) (RV bv2) = + vcat [ "op1: " <+> W4I.printSymExpr bv1 + , "op2: " <+> W4I.printSymExpr bv2 + ] + + ppPtr1 :: W4I.IsExpr (W4I.SymExpr sym) => RegValue' sym (LLVMPointerType w) -> Doc ann + ppPtr1 (RV p) = "Pointer:" <+> ppPtr p + + ppPtr2 (RV ptr1) (RV ptr2) = + vcat [ "Pointer 1:" <+> ppPtr ptr1 + , "Pointer 2:" <+> ppPtr ptr2 + ] + + ppOffset :: W4I.IsExpr e => e (BaseBVType w) -> Doc ann + ppOffset = ("Offset:" <+>) . W4I.printSymExpr + +pp :: (UndefinedBehavior e -> [Doc ann]) -- ^ Printer for constructor data + -> UndefinedBehavior e + -> Doc ann +pp extra ub = vcat (explain ub : extra ub ++ ppCitation ub) + +-- | Pretty-printer for symbolic backends +ppDetails :: + W4I.IsExpr (W4I.SymExpr sym) => + UndefinedBehavior (RegValue' sym) -> + Doc ann +ppDetails ub = vcat (details ub ++ ppCitation ub) + +ppCitation :: UndefinedBehavior e -> [Doc ann] +ppCitation ub = + (cat [ "Reference: " + , indent 2 (pretty (ppStd (standard ub))) + , indent 2 (cite ub) + ] + : case stdURL (standard ub) of + Just url -> [ indent 2 ("Document URL:" <+> pretty url) ] + Nothing -> []) + +-- ----------------------------------------------------------------------- +-- ** Instances + +$(return []) + +instance TestEqualityC UndefinedBehavior where + testEqualityC subterms x y = isJust $ + $(U.structuralTypeEquality [t|UndefinedBehavior|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType + , [| subterms |] + ) + , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType + , [| \a b -> if testEqualityC subterms a b then Just Refl else Nothing |] + ) + ] + ) x y + +instance OrdC UndefinedBehavior where + compareC subterms ub1 ub2 = toOrdering $ + $(U.structuralTypeOrd [t|UndefinedBehavior|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType + , [| subterms |] + ) + , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType + , [| \a b -> fromOrdering (compareC subterms a b) |] + ) + ] + ) ub1 ub2 + +instance FunctorF UndefinedBehavior where + fmapF = TF.fmapFDefault + +instance FoldableF UndefinedBehavior where + foldMapF = TF.foldMapFDefault + +instance TraversableF UndefinedBehavior where + traverseF subterms = + $(U.structuralTraversal [t|UndefinedBehavior|] + [ ( U.DataArg 0 `U.TypeApp` U.AnyType + , [| \_ x -> subterms x |] + ) + , ( U.ConType [t|Poison.Poison|] `U.TypeApp` U.AnyType + , [| \_ x -> traverseF subterms x |] + ) + ] + ) subterms + + +concUB :: forall sym. + W4I.IsExprBuilder sym => + sym -> + (forall tp. W4I.SymExpr sym tp -> IO (GroundValue tp)) -> + UndefinedBehavior (RegValue' sym) -> IO (UndefinedBehavior (RegValue' sym)) +concUB sym conc ub = + let bv :: forall w. (1 <= w) => RegValue' sym (BVType w) -> IO (RegValue' sym (BVType w)) + bv (RV x) = RV <$> concBV sym conc x in + case ub of + FreeBadOffset ptr -> + FreeBadOffset <$> concPtr' sym conc ptr + FreeUnallocated ptr -> + FreeUnallocated <$> concPtr' sym conc ptr + DoubleFree ptr -> + DoubleFree <$> concPtr' sym conc ptr + MemsetInvalidRegion ptr val len -> + MemsetInvalidRegion <$> concPtr' sym conc ptr <*> bv val <*> bv len + ReadBadAlignment ptr a -> + ReadBadAlignment <$> concPtr' sym conc ptr <*> pure a + WriteBadAlignment ptr a -> + WriteBadAlignment <$> concPtr' sym conc ptr <*> pure a + + PtrAddOffsetOutOfBounds ptr off -> + PtrAddOffsetOutOfBounds <$> concPtr' sym conc ptr <*> bv off + CompareInvalidPointer op p1 p2 -> + CompareInvalidPointer op <$> concPtr' sym conc p1 <*> concPtr' sym conc p2 + CompareDifferentAllocs p1 p2 -> + CompareDifferentAllocs <$> concPtr' sym conc p1 <*> concPtr' sym conc p2 + PtrSubDifferentAllocs p1 p2 -> + PtrSubDifferentAllocs <$> concPtr' sym conc p1 <*> concPtr' sym conc p2 + PointerFloatCast ptr tp -> + PointerFloatCast <$> concPtr' sym conc ptr <*> pure tp + PointerIntCast ptr tp -> + PointerIntCast <$> concPtr' sym conc ptr <*> pure tp + PointerUnsupportedOp ptr msg -> + PointerUnsupportedOp <$> concPtr' sym conc ptr <*> pure msg + ComparePointerToBV ptr val -> + ComparePointerToBV <$> concPtr' sym conc ptr <*> bv val + UDivByZero v1 v2 -> + UDivByZero <$> bv v1 <*> bv v2 + SDivByZero v1 v2 -> + SDivByZero <$> bv v1 <*> bv v2 + URemByZero v1 v2 -> + URemByZero <$> bv v1 <*> bv v2 + SRemByZero v1 v2 -> + SRemByZero <$> bv v1 <*> bv v2 + SDivOverflow v1 v2 -> + SDivOverflow <$> bv v1 <*> bv v2 + SRemOverflow v1 v2 -> + SRemOverflow <$> bv v1 <*> bv v2 + AbsIntMin v -> + AbsIntMin <$> bv v + + PoisonValueCreated poison -> + PoisonValueCreated <$> Poison.concPoison sym conc poison diff --git a/src/Lang/Crucible/LLVM/Eval.hs b/src/Lang/Crucible/LLVM/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Eval.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Lang.Crucible.LLVM.Eval + ( llvmExtensionEval + , callStackFromMemVar + ) where + +import Control.Lens ((^.), view) +import Control.Monad (forM_) +import qualified Data.List.NonEmpty as NE +import Data.Parameterized.TraversableF + +import What4.Interface + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.Simulator.ExecutionTree (SimState, CrucibleState) +import Lang.Crucible.Simulator.ExecutionTree (stateGlobals) +import Lang.Crucible.Simulator.GlobalState (lookupGlobal) +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.Evaluation +import Lang.Crucible.Simulator.RegValue +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Panic (panic) + +import qualified Lang.Crucible.LLVM.Arch.X86 as X86 +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.MemModel (memImplHeap) +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack) +import Lang.Crucible.LLVM.MemModel.MemLog (memState) +import Lang.Crucible.LLVM.MemModel.Partial +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.Types (Mem) + +callStackFromMemVar :: + SimState p sym ext rtp lang args -> + GlobalVar Mem -> + CallStack +callStackFromMemVar state mvar = + getCallStack . view memState . memImplHeap $ + case lookupGlobal mvar (state ^. stateGlobals) of + Just v -> v + Nothing -> + panic "callStackFromMemVar" + [ "Global heap value not initialized." + , "*** Global heap variable: " ++ show mvar + ] + +assertSideCondition :: + (HasLLVMAnn sym, IsSymBackend sym bak) => + bak -> + CallStack -> + LLVMSideCondition (RegValue' sym) -> + IO () +assertSideCondition bak callStack (LLVMSideCondition (RV p) ub) = + do let sym = backendGetSym bak + p' <- annotateUB sym callStack ub p + let err = AssertFailureSimError "Undefined behavior encountered" (show (UB.explain ub)) + assert bak p' err + +llvmExtensionEval :: + forall sym bak p ext rtp blocks r ctx. + (HasLLVMAnn sym, IsSymBackend sym bak) => + bak -> + IntrinsicTypes sym -> + (Int -> String -> IO ()) -> + CrucibleState p sym ext rtp blocks r ctx -> + EvalAppFunc sym LLVMExtensionExpr + +llvmExtensionEval bak _iTypes _logFn state eval e = + let sym = backendGetSym bak in + case e of + X86Expr ex -> X86.eval sym eval ex + + LLVM_SideConditions mvar _tp conds val -> + do let callStack = callStackFromMemVar state mvar + conds' <- traverse (traverseF (\x -> RV @sym <$> eval x)) (NE.toList conds) + forM_ conds' (assertSideCondition bak callStack) + eval val + + LLVM_PointerExpr _w blk off -> + do blk' <- eval blk + off' <- eval off + return (LLVMPointer blk' off') + + LLVM_PointerBlock _w ptr -> + llvmPointerBlock <$> eval ptr + + LLVM_PointerOffset _w ptr -> + llvmPointerOffset <$> eval ptr + + LLVM_PointerIte _w c x y -> + do cond <- eval c + LLVMPointer xblk xoff <- eval x + LLVMPointer yblk yoff <- eval y + blk <- natIte sym cond xblk yblk + off <- bvIte sym cond xoff yoff + return (LLVMPointer blk off) diff --git a/src/Lang/Crucible/LLVM/Extension.hs b/src/Lang/Crucible/LLVM/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Extension.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Extension +-- Description : LLVM interface for Crucible +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : rdockins@galois.com +-- Stability : provisional +-- +-- Syntax extension definitions for LLVM +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.Extension + ( module Lang.Crucible.LLVM.Extension.Arch + , module Lang.Crucible.LLVM.Extension.Syntax + , LLVM + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics ( Generic ) + +import Lang.Crucible.CFG.Extension + +import Lang.Crucible.LLVM.Extension.Arch +import Lang.Crucible.LLVM.Extension.Syntax + +-- | The Crucible extension type marker for LLVM. +data LLVM + deriving (Data, Eq, Generic , Ord, Typeable) + +-- ----------------------------------------------------------------------- +-- ** Syntax + +type instance ExprExtension LLVM = LLVMExtensionExpr +type instance StmtExtension LLVM = LLVMStmt + +instance IsSyntaxExtension LLVM diff --git a/src/Lang/Crucible/LLVM/Extension/Arch.hs b/src/Lang/Crucible/LLVM/Extension/Arch.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Extension/Arch.hs @@ -0,0 +1,64 @@ +-- | +-- Module : Lang.Crucible.LLVM.Arch +-- Description : Representations of LLVM architectures +-- Copyright : (c) Galois, Inc 2015-2018 +-- License : BSD3 +-- Maintainer : rdockins@galois.com +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.Extension.Arch + ( type LLVMArch + , type X86 + , ArchWidth + , ArchRepr(..) + ) where + +import GHC.Generics (Generic) +import Data.Parameterized (NatRepr) +import Data.Parameterized.Classes (OrdF(..)) +import qualified Data.Parameterized.TH.GADT as U +import Data.Type.Equality (TestEquality(..)) +import Data.Typeable (Typeable) +import GHC.TypeLits (Nat) + +-- | Data kind for representing LLVM architectures. +-- Currently only X86 variants are supported. +data LLVMArch = X86 Nat + deriving (Generic, Typeable) + +-- | LLVM Architecture tag for X86 variants +-- +-- @X86 :: Nat -> LLVMArch@ +type X86 = 'X86 + +-- | Type family defining the native machine word size +-- for a given architecture. +type family ArchWidth (arch :: LLVMArch) :: Nat where + ArchWidth (X86 wptr) = wptr + +-- | Runtime representation of architectures. +data ArchRepr (arch :: LLVMArch) where + X86Repr :: NatRepr w -> ArchRepr (X86 w) + +$(return []) + +instance TestEquality ArchRepr where + testEquality = + $(U.structuralTypeEquality [t|ArchRepr|] + [ (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + ]) + +instance OrdF ArchRepr where + compareF = + $(U.structuralTypeOrd [t|ArchRepr|] + [ (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + ]) diff --git a/src/Lang/Crucible/LLVM/Extension/Syntax.hs b/src/Lang/Crucible/LLVM/Extension/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Extension/Syntax.hs @@ -0,0 +1,456 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Extension.Syntax +-- Description : LLVM interface for Crucible +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : rdockins@galois.com +-- Stability : provisional +-- +-- Syntax extension definitions for LLVM +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Extension.Syntax where + +import Data.Kind +import Data.List.NonEmpty (NonEmpty) +import GHC.TypeLits +import Data.Text (Text) +import qualified Text.LLVM.AST as L +import Prettyprinter + +import Data.Functor.Classes (Eq1(..), Ord1(..)) +import Data.Parameterized.Classes +import Data.Parameterized.ClassesC (TestEqualityC(..), OrdC(..)) +import qualified Data.Parameterized.TH.GADT as U +import Data.Parameterized.TraversableF +import Data.Parameterized.TraversableFC + +import Lang.Crucible.CFG.Common +import Lang.Crucible.CFG.Extension +import Lang.Crucible.Types + +import Lang.Crucible.LLVM.Arch.X86 as X86 +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.Errors.UndefinedBehavior( UndefinedBehavior ) +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemModel.Type +import Lang.Crucible.LLVM.Types + + +data LLVMSideCondition (f :: CrucibleType -> Type) = + LLVMSideCondition (f BoolType) (UndefinedBehavior f) + +instance TestEqualityC LLVMSideCondition where + testEqualityC sub (LLVMSideCondition px dx) (LLVMSideCondition py dy) = + isJust (sub px py) && testEqualityC sub dx dy + +instance OrdC LLVMSideCondition where + compareC sub (LLVMSideCondition px dx) (LLVMSideCondition py dy) = + toOrdering (sub px py) <> compareC sub dx dy + +instance FunctorF LLVMSideCondition where + fmapF = fmapFDefault + +instance FoldableF LLVMSideCondition where + foldMapF = foldMapFDefault + +instance TraversableF LLVMSideCondition where + traverseF f (LLVMSideCondition p desc) = + LLVMSideCondition <$> f p <*> traverseF f desc + +data LLVMExtensionExpr :: (CrucibleType -> Type) -> (CrucibleType -> Type) where + + X86Expr :: + !(X86.ExtX86 f t) -> + LLVMExtensionExpr f t + + LLVM_SideConditions :: + !(GlobalVar Mem) {- Memory global variable -} -> + !(TypeRepr tp) -> + !(NonEmpty (LLVMSideCondition f)) -> + !(f tp) -> + LLVMExtensionExpr f tp + + LLVM_PointerExpr :: + (1 <= w) => !(NatRepr w) -> !(f NatType) -> !(f (BVType w)) -> + LLVMExtensionExpr f (LLVMPointerType w) + + LLVM_PointerBlock :: + (1 <= w) => !(NatRepr w) -> !(f (LLVMPointerType w)) -> + LLVMExtensionExpr f NatType + + LLVM_PointerOffset :: + (1 <= w) => !(NatRepr w) -> !(f (LLVMPointerType w)) -> + LLVMExtensionExpr f (BVType w) + + LLVM_PointerIte :: + (1 <= w) => !(NatRepr w) -> + !(f BoolType) -> !(f (LLVMPointerType w)) -> !(f (LLVMPointerType w)) -> + LLVMExtensionExpr f (LLVMPointerType w) + + +-- | Extension statements for LLVM. These statements represent the operations +-- necessary to interact with the LLVM memory model. +data LLVMStmt (f :: CrucibleType -> Type) :: CrucibleType -> Type where + + -- | Indicate the beginning of a new stack frame upon entry to a function. + LLVM_PushFrame :: + !Text -> + !(GlobalVar Mem) {- Memory global variable -} -> + LLVMStmt f UnitType + + -- | Indicate the end of the current stack frame upon exit from a function. + LLVM_PopFrame :: + !(GlobalVar Mem) {- Memory global variable -} -> + LLVMStmt f UnitType + + -- | Allocate a new memory object in the current stack frame. This memory + -- will be automatically deallocated when the corresponding PopFrame + -- statement is executed. + LLVM_Alloca :: + HasPtrWidth wptr => + !(NatRepr wptr) {- Pointer width -} -> + !(GlobalVar Mem) {- Memory global variable -} -> + !(f (BVType wptr)) {- Number of bytes to allocate -} -> + !Alignment {- Minimum alignment of this allocation -} -> + !String {- Location string to identify this allocation for debugging purposes -} -> + LLVMStmt f (LLVMPointerType wptr) + + -- | Load a value from the memory. The load is defined only if + -- the given pointer is a live pointer; if the bytes in the memory + -- at that location can be read and reconstructed into a value of the + -- desired type; and if the given pointer is actually aligned according + -- to the given alignment value. + LLVM_Load :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Memory global variable -} -> + !(f (LLVMPointerType wptr)) {- Pointer to load from -} -> + !(TypeRepr tp) {- Expected crucible type of the result -} -> + !StorageType {- Storage type -} -> + !Alignment {- Assumed alignment of the pointer -} -> + LLVMStmt f tp + + -- | Store a value in to the memory. The store is defined only if the given + -- pointer is a live pointer; if the given value fits into the memory object + -- at the location pointed to; and the given pointer is aligned according + -- to the given alignment value. + LLVM_Store :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Memory global variable -} -> + !(f (LLVMPointerType wptr)) {- Pointer to store at -} -> + !(TypeRepr tp) {- Crucible type of the value being stored -} -> + !StorageType {- Storage type of the value -} -> + !Alignment {- Assumed alignment of the pointer -} -> + !(f tp) {- Value to store -} -> + LLVMStmt f UnitType + + -- | Clear a region of memory by setting all the bytes in it to the zero byte. + -- This is primarily used for initializing the value of global variables, + -- but can also result from zero initializers. + LLVM_MemClear :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Memory global variable -} -> + !(f (LLVMPointerType wptr)) {- Pointer to store at -} -> + !Bytes {- Number of bytes to clear -} -> + LLVMStmt f UnitType + + -- | Load the Crucible function handle that corresponds to a function pointer value. + -- This load is defined only if the given pointer was previously allocated as + -- a function pointer value and associated with a Crucible function handle of + -- the expected type. + LLVM_LoadHandle :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Memory global variable -} -> + !(Maybe L.Type) {- expected LLVM type of the function (used only for pretty-printing) -} -> + !(f (LLVMPointerType wptr)) {- Pointer to load from -} -> + !(CtxRepr args) {- Expected argument types of the function -} -> + !(TypeRepr ret) {- Expected return type of the function -} -> + LLVMStmt f (FunctionHandleType args ret) + + -- | Resolve the given global symbol name to a pointer value. + LLVM_ResolveGlobal :: + HasPtrWidth wptr => + !(NatRepr wptr) {- Pointer width -} -> + !(GlobalVar Mem) {- Memory global variable -} -> + GlobalSymbol {- The symbol to resolve -} -> + LLVMStmt f (LLVMPointerType wptr) + + -- | Test two pointer values for equality. + -- Note! This operation is defined only + -- in case both pointers are live or null. + LLVM_PtrEq :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Pointer width -} -> + !(f (LLVMPointerType wptr)) {- First pointer to compare -} -> + !(f (LLVMPointerType wptr)) {- First pointer to compare -} -> + LLVMStmt f BoolType + + -- | Test two pointer values for ordering. + -- Note! This operation is only defined if + -- both pointers are live pointers into the + -- same memory object. + LLVM_PtrLe :: + HasPtrWidth wptr => + !(GlobalVar Mem) {- Pointer width -} -> + !(f (LLVMPointerType wptr)) {- First pointer to compare -} -> + !(f (LLVMPointerType wptr)) {- First pointer to compare -} -> + LLVMStmt f BoolType + + -- | Add an offset value to a pointer. + -- Note! This operation is only defined if both + -- the input pointer is a live pointer, and + -- the resulting computed pointer remains in the bounds + -- of its associated memory object (or one past the end). + LLVM_PtrAddOffset :: + HasPtrWidth wptr => + !(NatRepr wptr) {- Pointer width -} -> + !(GlobalVar Mem) {- Memory global variable -} -> + !(f (LLVMPointerType wptr)) {- Pointer value -} -> + !(f (BVType wptr)) {- Offset value -} -> + LLVMStmt f (LLVMPointerType wptr) + + -- | Compute the offset between two pointer values. + -- Note! This operation is only defined if both pointers + -- are live pointers into the same memory object. + LLVM_PtrSubtract :: + HasPtrWidth wptr => + !(NatRepr wptr) {- Pointer width -} -> + !(GlobalVar Mem) {- Memory global value -} -> + !(f (LLVMPointerType wptr)) {- First pointer -} -> + !(f (LLVMPointerType wptr)) {- Second pointer -} -> + LLVMStmt f (BVType wptr) + + -- | Debug information + LLVM_Debug :: + !(LLVM_Dbg f c) {- Debug variant -} -> + LLVMStmt f UnitType + +-- | Debug statement variants - these have no semantic meaning +data LLVM_Dbg f c where + -- | Annotates a value pointed to by a pointer with local-variable debug information + -- + -- + 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 + appType e = + case e of + X86Expr ex -> appType ex + LLVM_SideConditions _ tpr _ _ -> tpr + LLVM_PointerExpr w _ _ -> LLVMPointerRepr w + LLVM_PointerBlock _ _ -> NatRepr + LLVM_PointerOffset w _ -> BVRepr w + LLVM_PointerIte w _ _ _ -> LLVMPointerRepr w + +instance PrettyApp LLVMExtensionExpr where + ppApp pp e = + case e of + X86Expr ex -> ppApp pp ex + LLVM_SideConditions _ _ _conds ex -> + pretty "sideConditions" <+> pp ex -- TODO? Print the conditions? + LLVM_PointerExpr _ blk off -> + pretty "pointerExpr" <+> pp blk <+> pp off + LLVM_PointerBlock _ ptr -> + pretty "pointerBlock" <+> pp ptr + LLVM_PointerOffset _ ptr -> + pretty "pointerOffset" <+> pp ptr + LLVM_PointerIte _ cond x y -> + pretty "pointerIte" <+> pp cond <+> pp x <+> pp y + +instance TestEqualityFC LLVMExtensionExpr where + testEqualityFC testSubterm = + $(U.structuralTypeEquality [t|LLVMExtensionExpr|] + [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|]) + , (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|testEquality|]) + , (U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|testEqualityFC testSubterm|]) + , (U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType) + , [| \x y -> if liftEq (testEqualityC testSubterm) x y then Just Refl else Nothing |] + ) + ]) + +instance OrdFC LLVMExtensionExpr where + compareFC testSubterm = + $(U.structuralTypeOrd [t|LLVMExtensionExpr|] + [ (U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|]) + , (U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|compareF|]) + , (U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|compareFC testSubterm|]) + , (U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType) + , [| \x y -> fromOrdering (liftCompare (compareC testSubterm) x y) |] + ) + ]) + +instance FunctorFC LLVMExtensionExpr where + fmapFC = fmapFCDefault + +instance FoldableFC LLVMExtensionExpr where + foldMapFC = foldMapFCDefault + + +traverseConds :: + Applicative m => + (forall s. f s -> m (g s)) -> + NonEmpty (LLVMSideCondition f) -> + m (NonEmpty (LLVMSideCondition g)) +traverseConds f = traverse (traverseF f) + + +instance TraversableFC LLVMExtensionExpr where + traverseFC = $(U.structuralTraversal [t|LLVMExtensionExpr|] + [(U.ConType [t|X86.ExtX86|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|traverseFC|]) + ,(U.ConType [t|NonEmpty|] `U.TypeApp` (U.ConType [t|LLVMSideCondition|] `U.TypeApp` U.AnyType) + , [| traverseConds |] + ) + ]) + +instance TypeApp LLVMStmt where + appType = \case + LLVM_PushFrame{} -> knownRepr + LLVM_PopFrame{} -> knownRepr + LLVM_Alloca w _ _ _ _ -> LLVMPointerRepr w + LLVM_Load _ _ tp _ _ -> tp + LLVM_Store{} -> knownRepr + LLVM_MemClear{} -> knownRepr + LLVM_LoadHandle _ _ _ args ret -> FunctionHandleRepr args ret + LLVM_ResolveGlobal w _ _ -> LLVMPointerRepr w + LLVM_PtrEq{} -> knownRepr + LLVM_PtrLe{} -> knownRepr + LLVM_PtrAddOffset w _ _ _ -> LLVMPointerRepr w + LLVM_PtrSubtract w _ _ _ -> BVRepr w + LLVM_Debug{} -> knownRepr + +instance PrettyApp LLVMStmt where + ppApp pp = \case + LLVM_PushFrame nm mvar -> + pretty "pushFrame" <+> pretty nm <+> ppGlobalVar mvar + LLVM_PopFrame mvar -> + pretty "popFrame" <+> ppGlobalVar mvar + LLVM_Alloca _ mvar sz a loc -> + pretty "alloca" <+> ppGlobalVar mvar <+> pp sz <+> ppAlignment a <+> pretty loc + LLVM_Load mvar ptr _tpr tp a -> + pretty "load" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow tp <+> ppAlignment a + LLVM_Store mvar ptr _tpr tp a v -> + pretty "store" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow tp <+> ppAlignment a <+> pp v + LLVM_MemClear mvar ptr len -> + pretty "memClear" <+> ppGlobalVar mvar <+> pp ptr <+> viaShow len + LLVM_LoadHandle mvar ltp ptr _args _ret -> + pretty "loadFunctionHandle" <+> ppGlobalVar mvar <+> pp ptr <+> pretty "as" <+> viaShow ltp + LLVM_ResolveGlobal _ mvar gs -> + pretty "resolveGlobal" <+> ppGlobalVar mvar <+> viaShow (globalSymbolName gs) + LLVM_PtrEq mvar x y -> + pretty "ptrEq" <+> ppGlobalVar mvar <+> pp x <+> pp y + LLVM_PtrLe mvar x y -> + pretty "ptrLe" <+> ppGlobalVar mvar <+> pp x <+> pp y + LLVM_PtrAddOffset _ mvar x y -> + pretty "ptrAddOffset" <+> ppGlobalVar mvar <+> pp x <+> pp y + LLVM_PtrSubtract _ mvar x y -> + pretty "ptrSubtract" <+> ppGlobalVar mvar <+> pp x <+> pp y + LLVM_Debug dbg -> ppApp pp dbg + +instance PrettyApp LLVM_Dbg where + ppApp pp = \case + LLVM_Dbg_Addr x _ _ -> pretty "dbg.addr" <+> pp x + LLVM_Dbg_Declare x _ _ -> pretty "dbg.declare" <+> pp x + LLVM_Dbg_Value _ x _ _ -> pretty "dbg.value" <+> pp x + +-- TODO: move to a Pretty instance +ppGlobalVar :: GlobalVar Mem -> Doc ann +ppGlobalVar = viaShow + +-- TODO: move to a Pretty instance +ppAlignment :: Alignment -> Doc ann +ppAlignment = viaShow + +instance TestEqualityFC LLVM_Dbg where + testEqualityFC testSubterm = $(U.structuralTypeEquality [t|LLVM_Dbg|] + [(U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|]) + ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + ]) + +instance OrdFC LLVM_Dbg where + compareFC compareSubterm = $(U.structuralTypeOrd [t|LLVM_Dbg|] + [(U.DataArg 0 `U.TypeApp` U.AnyType, [|compareSubterm|]) + ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + ]) + +instance FoldableFC LLVM_Dbg where + foldMapFC = foldMapFCDefault +instance FunctorFC LLVM_Dbg where + fmapFC = fmapFCDefault + +instance TraversableFC LLVM_Dbg where + traverseFC = $(U.structuralTraversal [t|LLVM_Dbg|] []) + +instance TestEqualityFC LLVMStmt where + testEqualityFC testSubterm = + $(U.structuralTypeEquality [t|LLVMStmt|] + [(U.DataArg 0 `U.TypeApp` U.AnyType, [|testSubterm|]) + ,(U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + ,(U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|testEquality|]) + ,(U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|testEquality|]) + ,(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|testEqualityFC testSubterm|]) + ]) + +instance OrdFC LLVMStmt where + compareFC compareSubterm = + $(U.structuralTypeOrd [t|LLVMStmt|] + [(U.DataArg 0 `U.TypeApp` U.AnyType, [|compareSubterm|]) + ,(U.ConType [t|NatRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + ,(U.ConType [t|GlobalVar|] `U.TypeApp` U.AnyType, [|compareF|]) + ,(U.ConType [t|CtxRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + ,(U.ConType [t|TypeRepr|] `U.TypeApp` U.AnyType, [|compareF|]) + ,(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|compareFC compareSubterm|]) + ]) + +instance FunctorFC LLVMStmt where + fmapFC = fmapFCDefault + +instance FoldableFC LLVMStmt where + foldMapFC = foldMapFCDefault + +instance TraversableFC LLVMStmt where + traverseFC = + $(U.structuralTraversal [t|LLVMStmt|] + [(U.ConType [t|LLVM_Dbg|] `U.TypeApp` U.DataArg 0 `U.TypeApp` U.AnyType, [|traverseFC|]) + ]) diff --git a/src/Lang/Crucible/LLVM/Globals.hs b/src/Lang/Crucible/LLVM/Globals.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Globals.hs @@ -0,0 +1,420 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Globals +-- Description : Operations for working with LLVM global variables +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module provides support for dealing with LLVM global variables, +-- including initial allocation and populating variables with their +-- initial values. A @GlobalInitializerMap@ is constructed during +-- module translation and can subsequently be used to populate +-- global variables. This can either be done all at once using +-- @populateAllGlobals@; or it can be done in a more selective manner, +-- using one of the other \"populate\" operations. +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Globals + ( initializeMemory + , initializeAllMemory + , initializeMemoryConstGlobals + , populateGlobal + , populateGlobals + , populateAllGlobals + , populateConstGlobals + , registerFunPtr + + , GlobalInitializerMap + , makeGlobalMap + ) where + +import Control.Arrow ((&&&)) +import Control.Monad (foldM) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Except (MonadError(..)) +import Control.Lens hiding (op, (:>) ) +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.String +import Control.Monad.State (StateT, runStateT, get, put) +import Data.Maybe (fromMaybe) +import qualified Data.Parameterized.Context as Ctx + +import qualified Text.LLVM.AST as L + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.NatRepr as NatRepr + +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.MemModel +import qualified Lang.Crucible.LLVM.MemModel.Generic as G +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.Translation.Constant +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.Backend + +import What4.Interface + +import GHC.Stack + +------------------------------------------------------------------------ +-- GlobalInitializerMap + +-- | A @GlobalInitializerMap@ records the initialized values of globals in an @L.Module@. +-- +-- The @Left@ constructor is used to signal errors in translation, +-- which can happen when: +-- * The declaration is ill-typed +-- * The global isn't linked (@extern global@) +-- +-- The @Nothing@ constructor is used to signal that the global isn't actually a +-- compile-time constant. +-- +-- These failures are as granular as possible (attached to the values) +-- so that simulation still succeeds if the module has a bad global that the +-- verified function never touches. +-- +-- To actually initialize globals, saw-script translates them into +-- instances of @MemModel.LLVMVal@. +type GlobalInitializerMap = Map L.Symbol (L.Global, Either String (MemType, Maybe LLVMConst)) + + +------------------------------------------------------------------------ +-- makeGlobalMap + +-- | @makeGlobalMap@ creates a map from names of LLVM global variables +-- to the values of their initializers, if any are included in the module. +makeGlobalMap :: forall arch wptr. (?lc :: TypeContext, HasPtrWidth wptr) + => LLVMContext arch + -> L.Module + -> GlobalInitializerMap +makeGlobalMap ctx m = foldl' addAliases globalMap (Map.toList (llvmGlobalAliases ctx)) + + where + addAliases mp (glob, aliases) = + case Map.lookup glob mp of + Just initzr -> insertAll (map L.aliasName (Set.toList aliases)) initzr mp + Nothing -> mp -- should this be an error/exception? + + globalMap = Map.fromList $ map (L.globalSym &&& (id &&& globalToConst)) + (L.modGlobals m) + + insertAll ks v mp = foldr (flip Map.insert v) mp ks + + -- Catch the error from @transConstant@, turn it into @Either@ + globalToConst :: L.Global -> Either String (MemType, Maybe LLVMConst) + globalToConst g = + catchError + (globalToConst' g) + (\err -> Left $ + "Encountered error while processing global " + ++ show (LPP.ppSymbol (L.globalSym g)) + ++ ": " + ++ err) + + globalToConst' :: forall m. (MonadError String m) + => L.Global -> m (MemType, Maybe LLVMConst) + globalToConst' g = + do let ?lc = ctx^.llvmTypeCtx -- implicitly passed to transConstant + let gty = L.globalType g + let gval = L.globalValue g + mt <- liftMemType gty + val <- traverse (transConstant' mt) gval + return (mt, val) + +------------------------------------------------------------------------- +-- initializeMemory + +-- | Build the initial memory for an LLVM program. Note, this process +-- allocates space for global variables, but does not set their +-- initial values. +initializeAllMemory + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> LLVMContext arch + -> L.Module + -> IO (MemImpl sym) +initializeAllMemory = initializeMemory (const True) + +initializeMemoryConstGlobals + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> LLVMContext arch + -> L.Module + -> IO (MemImpl sym) +initializeMemoryConstGlobals = initializeMemory (L.gaConstant . L.globalAttrs) + +initializeMemory + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => (L.Global -> Bool) + -> bak + -> LLVMContext arch + -> L.Module + -> IO (MemImpl sym) +initializeMemory predicate bak llvm_ctx llvmModl = do + -- Create initial memory of appropriate endianness + let ?lc = llvm_ctx^.llvmTypeCtx + let dl = llvmDataLayout ?lc + let endianness = dl^.intLayout + mem0 <- emptyMem endianness + + -- allocate pointers values for function symbols, but do not + -- yet bind them to function handles + let decls = map Left (L.modDeclares llvmModl) ++ map Right (L.modDefines llvmModl) + mem <- foldM (allocLLVMFunPtr bak llvm_ctx) mem0 decls + + -- Allocate global values + let globAliases = llvmGlobalAliases llvm_ctx + let globals = L.modGlobals llvmModl + gs_alloc <- mapM (\g -> do + let err msg = malformedLLVMModule + ("Invalid type for global" <> fromString (show (L.globalSym g))) + [fromString msg] + ty <- either err return $ liftMemType $ L.globalType g + let sz = memTypeSize dl ty + let tyAlign = memTypeAlign dl ty + let aliases = map L.aliasName . Set.toList $ + fromMaybe Set.empty (Map.lookup (L.globalSym g) globAliases) + -- LLVM documentation regarding global variable alignment: + -- + -- An explicit alignment may be specified for + -- a global, which must be a power of 2. If + -- not present, or if the alignment is set to + -- zero, the alignment of the global is set by + -- the target to whatever it feels + -- convenient. If an explicit alignment is + -- specified, the global is forced to have + -- exactly that alignment. + alignment <- + case L.globalAlign g of + Just a | a > 0 -> + case toAlignment (toBytes a) of + Nothing -> fail $ "Invalid alignemnt: " ++ show a ++ "\n " ++ + "specified for global: " ++ show (L.globalSym g) + Just al -> return al + _ -> return tyAlign + return (g, aliases, sz, alignment)) + globals + allocGlobals bak (filter (\(g, _, _, _) -> predicate g) gs_alloc) mem + + +allocLLVMFunPtr :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + LLVMContext arch -> + MemImpl sym -> + Either L.Declare L.Define -> + IO (MemImpl sym) +allocLLVMFunPtr bak llvm_ctx mem decl = + do let (symbol, displayString) = + case decl of + Left d -> + let s@(L.Symbol nm) = L.decName d + in ( s, "[external function] " ++ nm ) + Right d -> + let s@(L.Symbol nm) = L.defName d + in ( s, "[defined function ] " ++ nm) + let funAliases = llvmFunctionAliases llvm_ctx + let aliases = map L.aliasName $ maybe [] Set.toList $ Map.lookup symbol funAliases + (_ptr, mem') <- registerFunPtr bak mem displayString symbol aliases + return mem' + +-- | Create a global allocation assocated with a function +registerFunPtr :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + -- | Display name + String -> + -- | Function name + L.Symbol -> + -- | Aliases + [L.Symbol] -> + IO (LLVMPtr sym wptr, MemImpl sym) +registerFunPtr bak mem displayName nm aliases = do + let sym = backendGetSym bak + z <- bvLit sym ?ptrWidth (BV.zero ?ptrWidth) + (ptr, mem') <- doMalloc bak G.GlobalAlloc G.Immutable displayName mem z noAlignment + return $ (ptr, registerGlobal mem' (nm:aliases) ptr) + +------------------------------------------------------------------------ +-- ** populateGlobals + +-- | Populate the globals mentioned in the given @GlobalInitializerMap@ +-- provided they satisfy the given filter function. +-- +-- This will (necessarily) populate any globals that the ones in the +-- filtered list transitively reference. +populateGlobals :: + ( ?lc :: TypeContext + , ?memOpts :: MemOptions + , 16 <= wptr + , HasPtrWidth wptr + , HasLLVMAnn sym + , IsSymBackend sym bak) => + (L.Global -> Bool) {- ^ Filter function, globals that cause this to return true will be populated -} -> + bak -> + GlobalInitializerMap -> + MemImpl sym -> + IO (MemImpl sym) +populateGlobals select bak gimap mem0 = foldM f mem0 (Map.elems gimap) + where + f mem (gl, _) | not (select gl) = return mem + f _ (_, Left msg) = fail msg + f mem (gl, Right (mty, Just cval)) = populateGlobal bak gl mty cval gimap mem + f mem (gl, Right (mty, Nothing)) = populateExternalGlobal bak gl mty mem + + +-- | Populate all the globals mentioned in the given @GlobalInitializerMap@. +populateAllGlobals :: + ( ?lc :: TypeContext + , ?memOpts :: MemOptions + , 16 <= wptr + , HasPtrWidth wptr + , HasLLVMAnn sym + , IsSymBackend sym bak) => + bak -> + GlobalInitializerMap -> + MemImpl sym -> + IO (MemImpl sym) +populateAllGlobals = populateGlobals (const True) + + +-- | Populate only the constant global variables mentioned in the +-- given @GlobalInitializerMap@ (and any they transitively refer to). +populateConstGlobals :: + ( ?lc :: TypeContext + , ?memOpts :: MemOptions + , 16 <= wptr + , HasPtrWidth wptr + , HasLLVMAnn sym + , IsSymBackend sym bak) => + bak -> + GlobalInitializerMap -> + MemImpl sym -> + IO (MemImpl sym) +populateConstGlobals = populateGlobals f + where f = L.gaConstant . L.globalAttrs + + +-- | Ordinarily external globals do not receive initalizing writes. However, +-- when 'lax-loads-and-stores` is enabled in the `stable-symbolic` mode, we +-- populate external global variables with fresh bytes. +populateExternalGlobal :: + ( ?lc :: TypeContext + , 16 <= wptr + , HasPtrWidth wptr + , IsSymBackend sym bak + , HasLLVMAnn sym + , HasCallStack + , ?memOpts :: MemOptions + ) => + bak -> + L.Global {- ^ The global to populate -} -> + MemType {- ^ Type of the global -} -> + MemImpl sym -> + IO (MemImpl sym) +populateExternalGlobal bak gl memty mem + | laxLoadsAndStores ?memOpts + , indeterminateLoadBehavior ?memOpts == StableSymbolic + + = do let sym = backendGetSym bak + bytes <- freshConstant sym emptySymbol + (BaseArrayRepr (Ctx.singleton $ BaseBVRepr ?ptrWidth) + (BaseBVRepr (knownNat @8))) + let dl = llvmDataLayout ?lc + let sz = memTypeSize dl memty + let tyAlign = memTypeAlign dl memty + sz' <- bvLit sym PtrWidth (bytesToBV PtrWidth sz) + ptr <- doResolveGlobal bak mem (L.globalSym gl) + doArrayConstStore bak mem ptr tyAlign bytes sz' + + | otherwise = return mem + + +-- | Write the value of the given LLVMConst into the given global variable. +-- This is intended to be used at initialization time, and will populate +-- even read-only global data. +populateGlobal :: forall sym bak wptr. + ( ?lc :: TypeContext + , 16 <= wptr + , HasPtrWidth wptr + , IsSymBackend sym bak + , HasLLVMAnn sym + , ?memOpts :: MemOptions + , HasCallStack + ) => + bak -> + L.Global {- ^ The global to populate -} -> + MemType {- ^ Type of the global -} -> + LLVMConst {- ^ Constant value to initialize with -} -> + GlobalInitializerMap -> + MemImpl sym -> + IO (MemImpl sym) +populateGlobal bak gl memty cval giMap mem = + do let sym = backendGetSym bak + let alignment = memTypeAlign (llvmDataLayout ?lc) memty + + -- So that globals can populate and look up the globals they reference + -- during initialization + let populateRec :: HasCallStack + => L.Symbol -> StateT (MemImpl sym) IO (LLVMPtr sym wptr) + populateRec symbol = do + memimpl0 <- get + memimpl <- + case Map.lookup symbol (memImplGlobalMap mem) of + Just _ -> pure memimpl0 -- We already populated this one + Nothing -> + -- For explanations of the various modes of failure, see the + -- comment on 'GlobalInitializerMap'. + case Map.lookup symbol giMap of + Nothing -> fail $ unlines $ + [ "Couldn't find global variable: " ++ show symbol ] + Just (glob, Left str) -> fail $ unlines $ + [ "Couldn't find global variable's initializer: " ++ + show symbol + , "Reason:" + , str + , "Full definition:" + , show glob + ] + Just (glob, Right (_, Nothing)) -> fail $ unlines $ + [ "Global was not a compile-time constant:" ++ show symbol + , "Full definition:" + , show glob + ] + Just (glob, Right (memty_, Just cval_)) -> + liftIO $ populateGlobal bak glob memty_ cval_ giMap memimpl0 + put memimpl + liftIO $ doResolveGlobal bak memimpl symbol + + ty <- toStorableType memty + ptr <- doResolveGlobal bak mem (L.globalSym gl) + (val, mem') <- runStateT (constToLLVMValP sym populateRec cval) mem + storeConstRaw bak mem' ptr ty alignment val diff --git a/src/Lang/Crucible/LLVM/Intrinsics.hs b/src/Lang/Crucible/LLVM/Intrinsics.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics.hs @@ -0,0 +1,423 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics +-- Description : Override definitions for LLVM intrinsic and basic +-- library functions +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.Intrinsics +( LLVM +, llvmIntrinsicTypes +, LLVMOverride(..) + +, register_llvm_overrides +, register_llvm_overrides_ +, llvmDeclToFunHandleRepr + +, module Lang.Crucible.LLVM.Intrinsics.Common +, module Lang.Crucible.LLVM.Intrinsics.Options +) where + +import Control.Lens hiding (op, (:>), Empty) +import Control.Monad (forM_) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Trans.Maybe +import Data.Foldable (asum) +import Data.List (stripPrefix, tails, isPrefixOf) +import qualified Text.LLVM.AST as L + +import qualified ABI.Itanium as ABI +import qualified Data.Parameterized.Map as MapF + +import What4.Interface + +import Lang.Crucible.Backend +import Lang.Crucible.Types +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.OverrideSim + +import Lang.Crucible.LLVM.Extension (ArchWidth, LLVM) +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext (TypeContext) + +import Lang.Crucible.LLVM.Intrinsics.Common +import qualified Lang.Crucible.LLVM.Intrinsics.LLVM as LLVM +import qualified Lang.Crucible.LLVM.Intrinsics.Libc as Libc +import qualified Lang.Crucible.LLVM.Intrinsics.Libcxx as Libcxx +import Lang.Crucible.LLVM.Intrinsics.Options + +llvmIntrinsicTypes :: IsSymInterface sym => IntrinsicTypes sym +llvmIntrinsicTypes = + MapF.insert (knownSymbol :: SymbolRepr "LLVM_memory") IntrinsicMuxFn $ + MapF.insert (knownSymbol :: SymbolRepr "LLVM_pointer") IntrinsicMuxFn $ + MapF.empty + +-- | Register all declare and define overrides +register_llvm_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) => + L.Module -> + [OverrideTemplate p sym arch rtp l a] {- ^ Additional "define" overrides -} -> + [OverrideTemplate p sym arch rtp l a] {- ^ Additional "declare" overrides -} -> + LLVMContext arch -> + OverrideSim p sym LLVM rtp l a () +register_llvm_overrides llvmModule defineOvrs declareOvrs llvmctx = + do register_llvm_define_overrides llvmModule defineOvrs llvmctx + register_llvm_declare_overrides llvmModule declareOvrs llvmctx + +-- | Filter the initial list of templates to only those that could +-- possibly match the given declaration based on straightforward, +-- relatively cheap string tests on the name of the declaration. +-- +-- Any remaining templates will then examine the declaration in +-- more detail, including examining function arguments +-- and the structure of C++ demangled names to extract more information. +filterTemplates :: + [OverrideTemplate p sym arch rtp l a] -> + L.Declare -> + [OverrideTemplate p sym arch rtp l a] +filterTemplates ts decl = filter (f . overrideTemplateMatcher) ts + where + L.Symbol nm = L.decName decl + + f (ExactMatch x) = x == nm + f (PrefixMatch pfx) = pfx `isPrefixOf` nm + f (SubstringsMatch as) = filterSubstrings as nm + + filterSubstrings [] _ = True + filterSubstrings (a:as) xs = + case restAfterSubstring a xs of + Nothing -> False + Just rest -> filterSubstrings as rest + + restAfterSubstring :: String -> String -> Maybe String + restAfterSubstring sub xs = asum [ stripPrefix sub tl | tl <- tails xs ] + + +-- | Helper function for registering overrides +register_llvm_overrides_ :: + LLVMContext arch -> + [OverrideTemplate p sym arch rtp l a] -> + [L.Declare] -> + OverrideSim p sym LLVM rtp l a () +register_llvm_overrides_ llvmctx acts decls = + forM_ decls $ \decl -> + do let acts' = filterTemplates acts decl + let L.Symbol nm = L.decName decl + let declnm = either (const Nothing) Just $ ABI.demangleName nm + runMaybeT (flip runReaderT (decl,declnm,llvmctx) $ asum (map overrideTemplateAction acts')) + +register_llvm_define_overrides :: + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) => + L.Module -> + [OverrideTemplate p sym arch rtp l a] -> + LLVMContext arch -> + OverrideSim p sym LLVM rtp l a () +register_llvm_define_overrides llvmModule addlOvrs llvmctx = + let ?lc = llvmctx^.llvmTypeCtx in + register_llvm_overrides_ llvmctx (addlOvrs ++ define_overrides) $ + (allModuleDeclares llvmModule) + +register_llvm_declare_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) => + L.Module -> + [OverrideTemplate p sym arch rtp l a] -> + LLVMContext arch -> + OverrideSim p sym LLVM rtp l a () +register_llvm_declare_overrides llvmModule addlOvrs llvmctx = + let ?lc = llvmctx^.llvmTypeCtx + in register_llvm_overrides_ llvmctx (addlOvrs ++ declare_overrides) $ + L.modDeclares llvmModule + + +-- | Register overrides for declared-but-not-defined functions +declare_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch + , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) => + [OverrideTemplate p sym arch rtp l a] +declare_overrides = + [ basic_llvm_override LLVM.llvmLifetimeStartOverride + , basic_llvm_override LLVM.llvmLifetimeEndOverride + , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload "start" (knownNat @8)) + , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload "end" (knownNat @8)) + , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload_opaque "start") + , basic_llvm_override (LLVM.llvmLifetimeOverrideOverload_opaque "end") + , basic_llvm_override (LLVM.llvmInvariantStartOverride (knownNat @8)) + , basic_llvm_override LLVM.llvmInvariantStartOverride_opaque + , basic_llvm_override (LLVM.llvmInvariantEndOverride (knownNat @8)) + , basic_llvm_override LLVM.llvmInvariantEndOverride_opaque + + , basic_llvm_override LLVM.llvmAssumeOverride + , basic_llvm_override LLVM.llvmTrapOverride + , basic_llvm_override LLVM.llvmUBSanTrapOverride + + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32 + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32_noalign + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_32_noalign_opaque + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64 + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64_noalign + , basic_llvm_override LLVM.llvmMemcpyOverride_8_8_64_noalign_opaque + + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32 + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32_noalign + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_32_noalign_opaque + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64 + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64_noalign + , basic_llvm_override LLVM.llvmMemmoveOverride_8_8_64_noalign_opaque + + , basic_llvm_override LLVM.llvmMemsetOverride_8_32 + , basic_llvm_override LLVM.llvmMemsetOverride_8_32_noalign + , basic_llvm_override LLVM.llvmMemsetOverride_8_32_noalign_opaque + , basic_llvm_override LLVM.llvmMemsetOverride_8_64 + , basic_llvm_override LLVM.llvmMemsetOverride_8_64_noalign + , basic_llvm_override LLVM.llvmMemsetOverride_8_64_noalign_opaque + + , basic_llvm_override LLVM.llvmObjectsizeOverride_32 + , basic_llvm_override LLVM.llvmObjectsizeOverride_64 + + , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null + , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null + + , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null_dynamic + , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null_dynamic + + , basic_llvm_override LLVM.llvmObjectsizeOverride_32_null_dynamic_opaque + , basic_llvm_override LLVM.llvmObjectsizeOverride_64_null_dynamic_opaque + + , basic_llvm_override LLVM.llvmPrefetchOverride + , basic_llvm_override LLVM.llvmPrefetchOverride_opaque + , basic_llvm_override LLVM.llvmPrefetchOverride_preLLVM10 + + , basic_llvm_override LLVM.llvmStacksave + , basic_llvm_override LLVM.llvmStackrestore + + , polymorphic1_llvm_override "llvm.ctlz" + (\w -> SomeLLVMOverride (LLVM.llvmCtlz w)) + , polymorphic1_llvm_override "llvm.cttz" + (\w -> SomeLLVMOverride (LLVM.llvmCttz w)) + , polymorphic1_llvm_override "llvm.ctpop" + (\w -> SomeLLVMOverride (LLVM.llvmCtpop w)) + , polymorphic1_llvm_override "llvm.bitreverse" + (\w -> SomeLLVMOverride (LLVM.llvmBitreverse w)) + , polymorphic1_llvm_override "llvm.abs" + (\w -> SomeLLVMOverride (LLVM.llvmAbsOverride w)) + + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @2)) -- 16 = 2 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @4)) -- 32 = 4 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @6)) -- 48 = 6 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @8)) -- 64 = 8 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @10)) -- 80 = 10 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @12)) -- 96 = 12 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @14)) -- 112 = 14 * 8 + , basic_llvm_override (LLVM.llvmBSwapOverride (knownNat @16)) -- 128 = 16 * 8 + + , polymorphic1_llvm_override "llvm.fshl" + (\w -> SomeLLVMOverride (LLVM.llvmFshl w)) + , polymorphic1_llvm_override "llvm.fshr" + (\w -> SomeLLVMOverride (LLVM.llvmFshr w)) + + , polymorphic1_llvm_override "llvm.expect" + (\w -> SomeLLVMOverride (LLVM.llvmExpectOverride w)) + , polymorphic1_llvm_override "llvm.sadd.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmSaddWithOverflow w)) + , polymorphic1_llvm_override "llvm.uadd.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmUaddWithOverflow w)) + , polymorphic1_llvm_override "llvm.ssub.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmSsubWithOverflow w)) + , polymorphic1_llvm_override "llvm.usub.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmUsubWithOverflow w)) + , polymorphic1_llvm_override "llvm.smul.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmSmulWithOverflow w)) + , polymorphic1_llvm_override "llvm.umul.with.overflow" + (\w -> SomeLLVMOverride (LLVM.llvmUmulWithOverflow w)) + + , polymorphic1_llvm_override "llvm.smax" + (\w -> SomeLLVMOverride (LLVM.llvmSmax w)) + , polymorphic1_llvm_override "llvm.smin" + (\w -> SomeLLVMOverride (LLVM.llvmSmin w)) + , polymorphic1_llvm_override "llvm.umax" + (\w -> SomeLLVMOverride (LLVM.llvmUmax w)) + , polymorphic1_llvm_override "llvm.umin" + (\w -> SomeLLVMOverride (LLVM.llvmUmin w)) + + , basic_llvm_override LLVM.llvmCopysignOverride_F32 + , basic_llvm_override LLVM.llvmCopysignOverride_F64 + , basic_llvm_override LLVM.llvmFabsF32 + , basic_llvm_override LLVM.llvmFabsF64 + + , basic_llvm_override LLVM.llvmCeilOverride_F32 + , basic_llvm_override LLVM.llvmCeilOverride_F64 + , basic_llvm_override LLVM.llvmFloorOverride_F32 + , basic_llvm_override LLVM.llvmFloorOverride_F64 + , basic_llvm_override LLVM.llvmSqrtOverride_F32 + , basic_llvm_override LLVM.llvmSqrtOverride_F64 + , basic_llvm_override LLVM.llvmSinOverride_F32 + , basic_llvm_override LLVM.llvmSinOverride_F64 + , basic_llvm_override LLVM.llvmCosOverride_F32 + , basic_llvm_override LLVM.llvmCosOverride_F64 + , basic_llvm_override LLVM.llvmPowOverride_F32 + , basic_llvm_override LLVM.llvmPowOverride_F64 + , basic_llvm_override LLVM.llvmExpOverride_F32 + , basic_llvm_override LLVM.llvmExpOverride_F64 + , basic_llvm_override LLVM.llvmLogOverride_F32 + , basic_llvm_override LLVM.llvmLogOverride_F64 + , basic_llvm_override LLVM.llvmExp2Override_F32 + , basic_llvm_override LLVM.llvmExp2Override_F64 + , basic_llvm_override LLVM.llvmLog2Override_F32 + , basic_llvm_override LLVM.llvmLog2Override_F64 + , basic_llvm_override LLVM.llvmLog10Override_F32 + , basic_llvm_override LLVM.llvmLog10Override_F64 + , basic_llvm_override LLVM.llvmFmaOverride_F32 + , basic_llvm_override LLVM.llvmFmaOverride_F64 + , basic_llvm_override LLVM.llvmFmuladdOverride_F32 + , basic_llvm_override LLVM.llvmFmuladdOverride_F64 + , basic_llvm_override LLVM.llvmIsFpclassOverride_F32 + , basic_llvm_override LLVM.llvmIsFpclassOverride_F64 + + -- C standard library functions + , basic_llvm_override Libc.llvmAbortOverride + , basic_llvm_override Libc.llvmAssertRtnOverride + , basic_llvm_override Libc.llvmAssertFailOverride + , basic_llvm_override Libc.llvmMemcpyOverride + , basic_llvm_override Libc.llvmMemcpyChkOverride + , basic_llvm_override Libc.llvmMemmoveOverride + , basic_llvm_override Libc.llvmMemsetOverride + , basic_llvm_override Libc.llvmMemsetChkOverride + , basic_llvm_override Libc.llvmMallocOverride + , basic_llvm_override Libc.llvmCallocOverride + , basic_llvm_override Libc.llvmFreeOverride + , basic_llvm_override Libc.llvmReallocOverride + , basic_llvm_override Libc.llvmStrlenOverride + , basic_llvm_override Libc.llvmPrintfOverride + , basic_llvm_override Libc.llvmPrintfChkOverride + , basic_llvm_override Libc.llvmPutsOverride + , basic_llvm_override Libc.llvmPutCharOverride + , basic_llvm_override Libc.llvmExitOverride + , basic_llvm_override Libc.llvmGetenvOverride + , basic_llvm_override Libc.llvmHtonlOverride + , basic_llvm_override Libc.llvmHtonsOverride + , basic_llvm_override Libc.llvmNtohlOverride + , basic_llvm_override Libc.llvmNtohsOverride + , basic_llvm_override Libc.llvmAbsOverride + , basic_llvm_override Libc.llvmLAbsOverride_32 + , basic_llvm_override Libc.llvmLAbsOverride_64 + , basic_llvm_override Libc.llvmLLAbsOverride + + , basic_llvm_override Libc.llvmCeilOverride + , basic_llvm_override Libc.llvmCeilfOverride + , basic_llvm_override Libc.llvmFloorOverride + , basic_llvm_override Libc.llvmFloorfOverride + , basic_llvm_override Libc.llvmFmaOverride + , basic_llvm_override Libc.llvmFmafOverride + , basic_llvm_override Libc.llvmIsinfOverride + , basic_llvm_override Libc.llvm__isinfOverride + , basic_llvm_override Libc.llvm__isinffOverride + , basic_llvm_override Libc.llvmIsnanOverride + , basic_llvm_override Libc.llvm__isnanOverride + , basic_llvm_override Libc.llvm__isnanfOverride + , basic_llvm_override Libc.llvmSqrtOverride + , basic_llvm_override Libc.llvmSqrtfOverride + , basic_llvm_override Libc.llvmSinOverride + , basic_llvm_override Libc.llvmSinfOverride + , basic_llvm_override Libc.llvmCosOverride + , basic_llvm_override Libc.llvmCosfOverride + , basic_llvm_override Libc.llvmTanOverride + , basic_llvm_override Libc.llvmTanfOverride + , basic_llvm_override Libc.llvmAsinOverride + , basic_llvm_override Libc.llvmAsinfOverride + , basic_llvm_override Libc.llvmAcosOverride + , basic_llvm_override Libc.llvmAcosfOverride + , basic_llvm_override Libc.llvmAtanOverride + , basic_llvm_override Libc.llvmAtanfOverride + , basic_llvm_override Libc.llvmSinhOverride + , basic_llvm_override Libc.llvmSinhfOverride + , basic_llvm_override Libc.llvmCoshOverride + , basic_llvm_override Libc.llvmCoshfOverride + , basic_llvm_override Libc.llvmTanhOverride + , basic_llvm_override Libc.llvmTanhfOverride + , basic_llvm_override Libc.llvmAsinhOverride + , basic_llvm_override Libc.llvmAsinhfOverride + , basic_llvm_override Libc.llvmAcoshOverride + , basic_llvm_override Libc.llvmAcoshfOverride + , basic_llvm_override Libc.llvmAtanhOverride + , basic_llvm_override Libc.llvmAtanhfOverride + , basic_llvm_override Libc.llvmHypotOverride + , basic_llvm_override Libc.llvmHypotfOverride + , basic_llvm_override Libc.llvmAtan2Override + , basic_llvm_override Libc.llvmAtan2fOverride + , basic_llvm_override Libc.llvmPowfOverride + , basic_llvm_override Libc.llvmPowOverride + , basic_llvm_override Libc.llvmExpOverride + , basic_llvm_override Libc.llvmExpfOverride + , basic_llvm_override Libc.llvmLogOverride + , basic_llvm_override Libc.llvmLogfOverride + , basic_llvm_override Libc.llvmExpm1Override + , basic_llvm_override Libc.llvmExpm1fOverride + , basic_llvm_override Libc.llvmLog1pOverride + , basic_llvm_override Libc.llvmLog1pfOverride + , basic_llvm_override Libc.llvmExp2Override + , basic_llvm_override Libc.llvmExp2fOverride + , basic_llvm_override Libc.llvmLog2Override + , basic_llvm_override Libc.llvmLog2fOverride + , basic_llvm_override Libc.llvmExp10Override + , basic_llvm_override Libc.llvmExp10fOverride + , basic_llvm_override Libc.llvmLog10Override + , basic_llvm_override Libc.llvmLog10fOverride + + , basic_llvm_override Libc.cxa_atexitOverride + , basic_llvm_override Libc.posixMemalignOverride + + -- C++ standard library functions + , Libcxx.register_cpp_override Libcxx.endlOverride + + -- Some architecture-dependent intrinsics + , basic_llvm_override LLVM.llvmX86_SSE2_storeu_dq + , basic_llvm_override LLVM.llvmX86_pclmulqdq + ] + + +-- | Register those overrides that should apply even when the corresponding +-- function has a definition +define_overrides :: + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?lc :: TypeContext) => + [OverrideTemplate p sym arch rtp l a] +define_overrides = + [ Libcxx.register_cpp_override Libcxx.putToOverride12 + , Libcxx.register_cpp_override Libcxx.putToOverride9 + , Libcxx.register_cpp_override Libcxx.endlOverride + , Libcxx.register_cpp_override Libcxx.sentryOverride + , Libcxx.register_cpp_override Libcxx.sentryBoolOverride + ] + +{- +Note [Overrides involving (unsigned) long] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Registering overrides for functions with `long` argument or result types is +tricky, as the size of a `long` varies wildly between different operating +systems and architectures. On Linux and macOS, `long` is 32 or 64 bits on +32- or 64-bit architectures, respectively. On Windows, however, `long` is +always 32 bits, regardless of architecture. There is a similar story for the +`unsigned long` type as well. + +To ensure that overrides for functions involving `long` are (at least to some +degree) portable, we register each override for `long`-using function twice: +once where `long` is assumed to be 32 bits, and once again where `long` is +assumed to be 64 bits. This is a somewhat heavy-handed solution, but it avoids +the need to predict what size `long` will be on a given target ahead of time. +-} diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Common.hs b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs @@ -0,0 +1,388 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Common +-- Description : Types used in override definitions +-- Copyright : (c) Galois, Inc 2015-2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.Intrinsics.Common + ( LLVMOverride(..) + , SomeLLVMOverride(..) + , RegOverrideM + , llvmSizeT + , llvmSSizeT + , OverrideTemplate(..) + , TemplateMatcher(..) + , callStackFromMemVar' + -- ** register_llvm_override + , basic_llvm_override + , polymorphic1_llvm_override + + , build_llvm_override + , register_llvm_override + , register_1arg_polymorphic_override + , bind_llvm_handle + , bind_llvm_func + , do_register_llvm_override + , alloc_and_register_override + ) where + +import qualified Text.LLVM.AST as L + +import Control.Applicative (empty) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Lens +import Control.Monad.Reader (ReaderT, ask, lift) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Data.List as List +import qualified Data.Text as Text +import Numeric (readDec) + +import qualified ABI.Itanium as ABI +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some (Some(..)) +import Data.Parameterized.TraversableFC (fmapFC) + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.Simulator.ExecutionTree (FnState(UseOverride)) +import Lang.Crucible.FunctionHandle (FnHandle, mkHandle') +import Lang.Crucible.Panic (panic) +import Lang.Crucible.Simulator (stateContext, simHandleAllocator) +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Utils.MonadVerbosity (getLogFunction) +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Types + +import What4.FunctionName + +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.Eval (callStackFromMemVar) +import Lang.Crucible.LLVM.Globals (registerFunPtr) +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack) +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Types + +-- | This type represents an implementation of an LLVM intrinsic function in +-- Crucible. +data LLVMOverride p sym args ret = + LLVMOverride + { llvmOverride_declare :: L.Declare -- ^ An LLVM name and signature for this intrinsic + , llvmOverride_args :: CtxRepr args -- ^ A representation of the argument types + , llvmOverride_ret :: TypeRepr ret -- ^ A representation of the return type + , llvmOverride_def :: + forall bak. + IsSymBackend sym bak => + GlobalVar Mem -> + bak -> + Ctx.Assignment (RegEntry sym) args -> + forall rtp args' ret'. + OverrideSim p sym LLVM rtp args' ret' (RegValue sym ret) + -- ^ The implementation of the intrinsic in the simulator monad + -- (@OverrideSim@). + } + +data SomeLLVMOverride p sym = + forall args ret. SomeLLVMOverride (LLVMOverride p sym args ret) + +-- | Convenient LLVM representation of the @size_t@ type. +llvmSizeT :: HasPtrWidth wptr => L.Type +llvmSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth + +-- | Convenient LLVM representation of the @ssize_t@ type. +llvmSSizeT :: HasPtrWidth wptr => L.Type +llvmSSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth + +data OverrideTemplate p sym arch rtp l a = + OverrideTemplate + { overrideTemplateMatcher :: TemplateMatcher + , overrideTemplateAction :: RegOverrideM p sym arch rtp l a () + } + +-- | This type controls whether an override is installed for a given name found in a module. +-- See 'filterTemplates'. +data TemplateMatcher + = ExactMatch String + | PrefixMatch String + | SubstringsMatch [String] + +type RegOverrideM p sym arch rtp l a = + ReaderT (L.Declare, Maybe ABI.DecodedName, LLVMContext arch) + (MaybeT (OverrideSim p sym LLVM rtp l a)) + +callStackFromMemVar' :: + GlobalVar Mem -> + OverrideSim p sym ext r args ret CallStack +callStackFromMemVar' mvar = use (to (flip callStackFromMemVar mvar)) + +------------------------------------------------------------------------ +-- ** register_llvm_override + +newtype ArgTransformer p sym args args' = + ArgTransformer { applyArgTransformer :: (forall rtp l a. + Ctx.Assignment (RegEntry sym) args -> + OverrideSim p sym LLVM rtp l a (Ctx.Assignment (RegEntry sym) args')) } + +newtype ValTransformer p sym tp tp' = + ValTransformer { applyValTransformer :: (forall rtp l a. + RegValue sym tp -> + OverrideSim p sym LLVM rtp l a (RegValue sym tp')) } + +transformLLVMArgs :: forall m p sym bak args args'. + (IsSymBackend sym bak, Monad m, HasLLVMAnn sym) => + -- | This function name is only used in panic messages. + FunctionName -> + bak -> + CtxRepr args' -> + CtxRepr args -> + m (ArgTransformer p sym args args') +transformLLVMArgs _fnName _ Ctx.Empty Ctx.Empty = + return (ArgTransformer (\_ -> return Ctx.Empty)) +transformLLVMArgs fnName bak (rest' Ctx.:> tp') (rest Ctx.:> tp) = do + return (ArgTransformer + (\(xs Ctx.:> x) -> + do (ValTransformer f) <- transformLLVMRet fnName bak tp tp' + (ArgTransformer fs) <- transformLLVMArgs fnName bak rest' rest + xs' <- fs xs + x' <- RegEntry tp' <$> f (regValue x) + pure (xs' Ctx.:> x'))) +transformLLVMArgs fnName _ _ _ = + panic "Intrinsics.transformLLVMArgs" + [ "transformLLVMArgs: argument shape mismatch!" + , "in function: " ++ Text.unpack (functionName fnName) + ] + +transformLLVMRet :: + (IsSymBackend sym bak, Monad m, HasLLVMAnn sym) => + -- | This function name is only used in panic messages. + FunctionName -> + bak -> + TypeRepr ret -> + TypeRepr ret' -> + m (ValTransformer p sym ret ret') +transformLLVMRet _fnName bak (BVRepr w) (LLVMPointerRepr w') + | Just Refl <- testEquality w w' + = return (ValTransformer (liftIO . llvmPointer_bv (backendGetSym bak))) +transformLLVMRet _fnName bak (LLVMPointerRepr w) (BVRepr w') + | Just Refl <- testEquality w w' + = return (ValTransformer (liftIO . projectLLVM_bv bak)) +transformLLVMRet fnName bak (VectorRepr tp) (VectorRepr tp') + = do ValTransformer f <- transformLLVMRet fnName bak tp tp' + return (ValTransformer (traverse f)) +transformLLVMRet fnName bak (StructRepr ctx) (StructRepr ctx') + = do ArgTransformer tf <- transformLLVMArgs fnName bak ctx' ctx + return (ValTransformer (\vals -> + let vals' = Ctx.zipWith (\tp (RV v) -> RegEntry tp v) ctx vals in + fmapFC (\x -> RV (regValue x)) <$> tf vals')) + +transformLLVMRet _fnName _bak ret ret' + | Just Refl <- testEquality ret ret' + = return (ValTransformer return) +transformLLVMRet fnName _bak ret ret' + = panic "Intrinsics.transformLLVMRet" + [ "Cannot transform types" + , "*** Source type: " ++ show ret + , "*** Target type: " ++ show ret' + , "in function: " ++ Text.unpack (functionName fnName) + ] + +-- | Do some pipe-fitting to match a Crucible override function into the shape +-- expected by the LLVM calling convention. This basically just coerces +-- between values of @BVType w@ and values of @LLVMPointerType w@. +build_llvm_override :: + HasLLVMAnn sym => + FunctionName -> + CtxRepr args -> + TypeRepr ret -> + CtxRepr args' -> + TypeRepr ret' -> + (forall bak rtp' l' a'. IsSymBackend sym bak => + bak -> + Ctx.Assignment (RegEntry sym) args -> + OverrideSim p sym LLVM rtp' l' a' (RegValue sym ret)) -> + OverrideSim p sym LLVM rtp l a (Override p sym LLVM args' ret') +build_llvm_override fnm args ret args' ret' llvmOverride = + ovrWithBackend $ \bak -> + do fargs <- transformLLVMArgs fnm bak args args' + fret <- transformLLVMRet fnm bak ret ret' + return $ mkOverride' fnm ret' $ + do RegMap xs <- getOverrideArgs + ovrWithBackend $ \bak' -> + applyValTransformer fret =<< llvmOverride bak' =<< applyArgTransformer fargs xs + +polymorphic1_llvm_override :: forall p sym arch wptr l a rtp. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + String -> + (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) -> + OverrideTemplate p sym arch rtp l a +polymorphic1_llvm_override prefix fn = + OverrideTemplate (PrefixMatch prefix) (register_1arg_polymorphic_override prefix fn) + +register_1arg_polymorphic_override :: forall p sym arch wptr l a rtp. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + String -> + (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) -> + RegOverrideM p sym arch rtp l a () +register_1arg_polymorphic_override prefix overrideFn = + do (L.Declare{ L.decName = L.Symbol nm },_,_) <- ask + case List.stripPrefix prefix nm of + Just ('.':'i': (readDec -> (sz,[]):_)) + | Some w <- mkNatRepr sz + , Just LeqProof <- isPosNat w + -> case overrideFn w of SomeLLVMOverride ovr -> register_llvm_override ovr + _ -> empty + +basic_llvm_override :: forall p args ret sym arch wptr l a rtp. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + LLVMOverride p sym args ret -> + OverrideTemplate p sym arch rtp l a +basic_llvm_override ovr = OverrideTemplate (ExactMatch nm) (register_llvm_override ovr) + where L.Symbol nm = L.decName (llvmOverride_declare ovr) + + +-- | Check that the requested declaration matches the provided declaration. In +-- this context, \"matching\" means that both declarations have identical names, +-- as well as equal argument and result types. When checking types for equality, +-- we consider opaque pointer types to be equal to non-opaque pointer types so +-- that we do not have to define quite so many overrides with different +-- combinations of pointer types. +isMatchingDeclaration :: + L.Declare {- ^ Requested declaration -} -> + L.Declare {- ^ Provided declaration for intrinsic -} -> + Bool +isMatchingDeclaration requested provided = and + [ L.decName requested == L.decName provided + , matchingArgList (L.decArgs requested) (L.decArgs provided) + , L.decRetType requested `L.eqTypeModuloOpaquePtrs` L.decRetType provided + -- TODO? do we need to pay attention to various attributes? + ] + + where + matchingArgList [] [] = True + matchingArgList [] _ = L.decVarArgs requested + matchingArgList _ [] = L.decVarArgs provided + matchingArgList (x:xs) (y:ys) = x `L.eqTypeModuloOpaquePtrs` y && matchingArgList xs ys + +register_llvm_override :: forall p args ret sym arch wptr l a rtp. + (IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym) => + LLVMOverride p sym args ret -> + RegOverrideM p sym arch rtp l a () +register_llvm_override llvmOverride = do + (requestedDecl,_,llvmctx) <- ask + let decl = llvmOverride_declare llvmOverride + if not (isMatchingDeclaration requestedDecl decl) then + do when (L.decName requestedDecl == L.decName decl) $ + do logFn <- lift $ lift $ getLogFunction + liftIO $ logFn 3 $ unlines + [ "Mismatched declaration signatures" + , " *** requested: " ++ show requestedDecl + , " *** found: " ++ show decl + , "" + ] + empty + else lift (lift (do_register_llvm_override llvmctx llvmOverride)) + +-- | Bind a function handle, and also bind the function to the global function +-- allocation in the LLVM memory. +bind_llvm_handle :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMContext arch -> + L.Symbol -> + FnHandle args ret -> + FnState p sym LLVM args ret -> + OverrideSim p sym LLVM rtp l a () +bind_llvm_handle llvmCtx nm hdl impl = do + let mvar = llvmMemVar llvmCtx + bindFnHandle hdl impl + mem <- readGlobal mvar + mem' <- ovrWithBackend $ \bak -> liftIO $ bindLLVMFunPtr bak nm hdl mem + writeGlobal mvar mem' + +-- | Low-level function to register LLVM functions. +-- +-- Creates and binds a function handle, and also binds the function to the +-- global function allocation in the LLVM memory. +bind_llvm_func :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMContext arch -> + L.Symbol -> + Ctx.Assignment TypeRepr args -> + TypeRepr ret -> + FnState p sym LLVM args ret -> + OverrideSim p sym LLVM rtp l a () +bind_llvm_func llvmCtx nm args ret impl = do + let L.Symbol strNm = nm + let fnm = functionNameFromText (Text.pack strNm) + ctx <- use stateContext + let ha = simHandleAllocator ctx + h <- liftIO $ mkHandle' ha fnm args ret + bind_llvm_handle llvmCtx nm h impl + +-- | Low-level function to register LLVM overrides. +-- +-- Type-checks the LLVM override against the 'L.Declare' it contains, adapting +-- its arguments and return values as necessary. Then creates and binds +-- a function handle, and also binds the function to the global function +-- allocation in the LLVM memory. +-- +-- Useful when you don\'t have access to a full LLVM AST, e.g., when parsing +-- Crucible CFGs written in crucible-syntax. For more usual cases, use +-- 'Lang.Crucible.LLVM.Intrinsics.register_llvm_overrides'. +do_register_llvm_override :: forall p args ret sym arch wptr l a rtp. + (IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym) => + LLVMContext arch -> + LLVMOverride p sym args ret -> + OverrideSim p sym LLVM rtp l a () +do_register_llvm_override llvmctx llvmOverride = do + let decl = llvmOverride_declare llvmOverride + let (L.Symbol str_nm) = L.decName decl + let fnm = functionNameFromText (Text.pack str_nm) + + let mvar = llvmMemVar llvmctx + let overrideArgs = llvmOverride_args llvmOverride + let overrideRet = llvmOverride_ret llvmOverride + + let ?lc = llvmctx^.llvmTypeCtx + + llvmDeclToFunHandleRepr' decl $ \args ret -> do + o <- build_llvm_override fnm overrideArgs overrideRet args ret + (\bak asgn -> llvmOverride_def llvmOverride mvar bak asgn) + bind_llvm_func llvmctx (L.decName decl) args ret (UseOverride o) + +-- | Create an allocation for an override and register it. +-- +-- Useful when registering an override for a function in an LLVM memory that +-- wasn't initialized with the functions in "Lang.Crucible.LLVM.Globals", e.g., +-- when parsing Crucible CFGs written in crucible-syntax. For more usual cases, +-- use 'Lang.Crucible.LLVM.Intrinsics.register_llvm_overrides'. +-- +-- c.f. 'Lang.Crucible.LLVM.Globals.allocLLVMFunPtr' +alloc_and_register_override :: + (IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym, ?memOpts :: MemOptions) => + bak -> + LLVMContext arch -> + LLVMOverride p sym args ret -> + -- | Aliases + [L.Symbol] -> + OverrideSim p sym LLVM rtp l a () +alloc_and_register_override bak llvmctx llvmOverride aliases = do + let L.Declare { L.decName = symb@(L.Symbol nm) } = llvmOverride_declare llvmOverride + let mvar = llvmMemVar llvmctx + mem <- readGlobal mvar + (_ptr, mem') <- liftIO (registerFunPtr bak mem nm symb aliases) + writeGlobal mvar mem' + do_register_llvm_override llvmctx llvmOverride diff --git a/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs @@ -0,0 +1,1573 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.LLVM +-- Description : Override definitions for LLVM intrinsic and basic +-- library functions +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.Intrinsics.LLVM where + +import GHC.TypeNats (KnownNat) +import Control.Lens hiding (op, (:>), Empty) +import Control.Monad (foldM, unless) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Bits ((.&.)) +import qualified Data.Vector as V +import qualified Text.LLVM.AST as L + +import qualified Data.BitVector.Sized as BV +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Context ( pattern (:>), pattern Empty ) + +import What4.Interface +import What4.InterpretedFloatingPoint +import qualified What4.SpecialFunctions as W4 + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.Types +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError (SimErrorReason(AssertFailureSimError)) + +import Lang.Crucible.LLVM.Bytes (Bytes(..)) +import Lang.Crucible.LLVM.DataLayout (noAlignment) +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.QQ( llvmOvr ) + +import Lang.Crucible.LLVM.Intrinsics.Common +import qualified Lang.Crucible.LLVM.Intrinsics.Libc as Libc + +------------------------------------------------------------------------ +-- ** Declarations + +-- | This intrinsic is currently a no-op. +-- +-- We might want to support this in the future to catch undefined memory +-- accesses. +-- +-- +llvmLifetimeStartOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType +llvmLifetimeStartOverride = + [llvmOvr| void @llvm.lifetime.start( i64, i8* ) |] + (\_ops _sym _args -> return ()) + +-- | See comment on 'llvmLifetimeStartOverride' +-- +-- +llvmLifetimeEndOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType +llvmLifetimeEndOverride = + [llvmOvr| void @llvm.lifetime.end( i64, i8* ) |] + (\_ops _sym _args -> return ()) + +-- | This is a no-op. +-- +-- The language reference doesn't mention the use of this intrinsic. +llvmLifetimeOverrideOverload + :: forall width sym wptr p + . ( 1 <= width, KnownNat width + , IsSymInterface sym, HasPtrWidth wptr) + => String -- ^ "start" or "end" + -> NatRepr width + -> LLVMOverride p sym + (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) + UnitType -- It appears in practice that this is always void +llvmLifetimeOverrideOverload startOrEnd w = + let nm = L.Symbol ("llvm.lifetime." ++ startOrEnd ++ ".p0i" ++ show (widthVal w)) in + [llvmOvr| void $nm ( i64, #w * ) |] + (\_ops _sym _args -> return ()) + +-- | Like 'llvmLifetimeOverrideOverload', but with an opaque pointer type. +llvmLifetimeOverrideOverload_opaque + :: forall sym wptr p + . (IsSymInterface sym, HasPtrWidth wptr) + => String -- ^ "start" or "end" + -> LLVMOverride p sym + (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) + UnitType -- It appears in practice that this is always void +llvmLifetimeOverrideOverload_opaque startOrEnd = + let nm = L.Symbol ("llvm.lifetime." ++ startOrEnd ++ ".p0") in + [llvmOvr| void $nm ( i64, ptr ) |] + (\_ops _sym _args -> return ()) + +-- | This intrinsic is currently a no-op. +-- +-- We might want to support this in the future to catch undefined memory +-- writes. +-- +-- +llvmInvariantStartOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => NatRepr width + -> LLVMOverride p sym + (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) + (LLVMPointerType wptr) +llvmInvariantStartOverride w = + let nm = L.Symbol ("llvm.invariant.start.p0i" ++ show (widthVal w)) in + [llvmOvr| {}* $nm ( i64, #w * ) |] + (\_ops bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth)) + +-- | Like 'llvmInvariantStartOverride', but with an opaque pointer type. +llvmInvariantStartOverride_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) + (LLVMPointerType wptr) +llvmInvariantStartOverride_opaque = + let nm = L.Symbol "llvm.invariant.start.p0" in + [llvmOvr| {}* $nm ( i64, ptr ) |] + (\_ops bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth)) + +-- | See comment on 'llvmInvariantStartOverride'. +llvmInvariantEndOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => NatRepr width + -> LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 64 ::> LLVMPointerType wptr) + UnitType +llvmInvariantEndOverride w = + let nm = L.Symbol ("llvm.invariant.end.p0i" ++ show (widthVal w)) in + [llvmOvr| void $nm ( {}*, i64, #w * ) |] + (\_ops _bak _args -> return ()) + +-- | See comment on 'llvmInvariantStartOverride_opaque'. +llvmInvariantEndOverride_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 64 ::> LLVMPointerType wptr) + UnitType +llvmInvariantEndOverride_opaque = + let nm = L.Symbol "llvm.invariant.end.p0" in + [llvmOvr| void $nm ( {}*, i64, ptr ) |] + (\_ops _bak _args -> return ()) + +-- | This instruction is a hint to optimizers, it isn't really useful for us. +-- +-- Its runtime behavior of that of Haskell\'s 'const': just ignore the second +-- argument. +llvmExpectOverride + :: (IsSymInterface sym, 1 <= width) + => NatRepr width + -> LLVMOverride p sym + (EmptyCtx ::> BVType width ::> BVType width) + (BVType width) +llvmExpectOverride w = + let nm = L.Symbol ("llvm.expect.i" ++ show (widthVal w)) in + [llvmOvr| #w $nm ( #w, #w ) |] + (\_ops _bak args -> + Ctx.uncurryAssignment (\val _ -> pure (regValue val)) args) + +-- | This intrinsic asserts that its argument is equal to 1. +-- +-- We could have this generate a verification condition, but that would catch +-- clang compiler bugs (or Crucible bugs) more than user code bugs. +llvmAssumeOverride + :: (IsSymInterface sym) + => LLVMOverride p sym (EmptyCtx ::> BVType 1) UnitType +llvmAssumeOverride = + [llvmOvr| void @llvm.assume ( i1 ) |] + (\_ops _bak _args -> return ()) + +-- | This intrinsic is sometimes inserted by clang, and we interpret it +-- as an assertion failure, similar to calling @abort()@. +llvmTrapOverride + :: (IsSymInterface sym) + => LLVMOverride p sym EmptyCtx UnitType +llvmTrapOverride = + [llvmOvr| void @llvm.trap() |] + (\_ops bak _args -> liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.trap() called" "") + +-- | This is like @llvm.trap()@, but with an argument indicating which sort of +-- undefined behavior was trapped. The argument acts as an index into +-- . +-- Ideally, we would do something intelligent with this argument—see #368. +llvmUBSanTrapOverride :: + IsSymInterface sym => + LLVMOverride p sym (EmptyCtx ::> BVType 8) UnitType +llvmUBSanTrapOverride = + [llvmOvr| void @llvm.ubsantrap( i8 ) |] + (\_ops bak _args -> liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.ubsantrap() called" "") + +llvmStacksave + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym EmptyCtx (LLVMPointerType wptr) +llvmStacksave = + [llvmOvr| i8* @llvm.stacksave() |] + (\_memOps bak _args -> liftIO (mkNullPointer (backendGetSym bak) PtrWidth)) + +llvmStackrestore + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) UnitType +llvmStackrestore = + [llvmOvr| void @llvm.stackrestore( i8* ) |] + (\_memOps _bak _args -> return ()) + +llvmMemmoveOverride_8_8_32 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 32 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_32 = + [llvmOvr| void @llvm.memmove.p0i8.p0i8.i32( i8*, i8*, i32, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove bak memOps dst src len v) args) + +llvmMemmoveOverride_8_8_32_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_32_noalign = + [llvmOvr| void @llvm.memmove.p0i8.p0i8.i32( i8*, i8*, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args) + +llvmMemmoveOverride_8_8_32_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_32_noalign_opaque = + [llvmOvr| void @llvm.memmove.p0.p0.i32( ptr, ptr, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args) + + +llvmMemmoveOverride_8_8_64 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 32 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_64 = + [llvmOvr| void @llvm.memmove.p0i8.p0i8.i64( i8*, i8*, i64, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove bak memOps dst src len v) args) + +llvmMemmoveOverride_8_8_64_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_64_noalign = + [llvmOvr| void @llvm.memmove.p0i8.p0i8.i64( i8*, i8*, i64, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args) + +llvmMemmoveOverride_8_8_64_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 1) + UnitType +llvmMemmoveOverride_8_8_64_noalign_opaque = + [llvmOvr| void @llvm.memmove.p0.p0.i64( ptr, ptr, i64, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (Libc.callMemmove bak memOps) args) + + +llvmMemsetOverride_8_64 + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 64 + ::> BVType 32 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_64 = + [llvmOvr| void @llvm.memset.p0i8.i64( i8*, i8, i64, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset bak memOps dst val len v) args) + +llvmMemsetOverride_8_64_noalign + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 64 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_64_noalign = + [llvmOvr| void @llvm.memset.p0i8.i64( i8*, i8, i64, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args) + +llvmMemsetOverride_8_64_noalign_opaque + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 64 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_64_noalign_opaque = + [llvmOvr| void @llvm.memset.p0.i64( ptr, i8, i64, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args) + + +llvmMemsetOverride_8_32 + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 32 + ::> BVType 32 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_32 = + [llvmOvr| void @llvm.memset.p0i8.i32( i8*, i8, i32, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset bak memOps dst val len v) args) + +llvmMemsetOverride_8_32_noalign + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 32 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_32_noalign = + [llvmOvr| void @llvm.memset.p0i8.i32( i8*, i8, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args) + +llvmMemsetOverride_8_32_noalign_opaque + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 8 + ::> BVType 32 + ::> BVType 1) + UnitType +llvmMemsetOverride_8_32_noalign_opaque = + [llvmOvr| void @llvm.memset.p0.i32( ptr, i8, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemset bak memOps) args) + + +llvmMemcpyOverride_8_8_32 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 32 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_32 = + [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i32( i8*, i8*, i32, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy bak memOps dst src len v) args) + +llvmMemcpyOverride_8_8_32_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_32_noalign = + [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i32( i8*, i8*, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args) + +llvmMemcpyOverride_8_8_32_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 32 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_32_noalign_opaque = + [llvmOvr| void @llvm.memcpy.p0.p0.i32( ptr, ptr, i32, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args) + + +llvmMemcpyOverride_8_8_64 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 32 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_64 = + [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i64( i8*, i8*, i64, i32, i1 ) |] + (\memOps bak args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy bak memOps dst src len v) args) + +llvmMemcpyOverride_8_8_64_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_64_noalign = + [llvmOvr| void @llvm.memcpy.p0i8.p0i8.i64( i8*, i8*, i64, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args) + +llvmMemcpyOverride_8_8_64_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr + ::> BVType 64 ::> BVType 1) + UnitType +llvmMemcpyOverride_8_8_64_noalign_opaque = + [llvmOvr| void @llvm.memcpy.p0.p0.i64( ptr, ptr, i64, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (Libc.callMemcpy bak memOps) args) + + +llvmObjectsizeOverride_32 + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32 = + [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize bak memOps knownNat) args) + +llvmObjectsizeOverride_32_null + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32_null = + [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null bak memOps knownNat) args) + +llvmObjectsizeOverride_32_null_dynamic + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32_null_dynamic = + [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args) + +llvmObjectsizeOverride_32_null_dynamic_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32_null_dynamic_opaque = + [llvmOvr| i32 @llvm.objectsize.i32.p0( ptr, i1, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args) + +llvmObjectsizeOverride_64 + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64 = + [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize bak memOps knownNat) args) + +llvmObjectsizeOverride_64_null + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64_null = + [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null bak memOps knownNat) args) + +llvmObjectsizeOverride_64_null_dynamic + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64_null_dynamic = + [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args) + +llvmObjectsizeOverride_64_null_dynamic_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1 ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64_null_dynamic_opaque = + [llvmOvr| i64 @llvm.objectsize.i64.p0( ptr, i1, i1, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic bak memOps knownNat) args) + +-- | This instruction is a hint to code generators, which means that it is a +-- no-op for us. +-- +-- +llvmPrefetchOverride :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride = + [llvmOvr| void @llvm.prefetch.p0i8( i8*, i32, i32, i32 ) |] + (\_memOps _bak _args -> pure ()) + +-- | Like 'llvmPrefetchOverride', but with an opaque pointer type. +llvmPrefetchOverride_opaque :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride_opaque = + [llvmOvr| void @llvm.prefetch.p0( ptr, i32, i32, i32 ) |] + (\_memOps _bak _args -> pure ()) + +-- | This instruction is a hint to code generators, which means that it is a +-- no-op for us. +-- +-- See also 'llvmPrefetchOverride'. This version exists for compatibility with +-- pre-10 versions of LLVM, where llvm.prefetch always assumed that the first +-- argument resides in address space 0. +-- +-- +llvmPrefetchOverride_preLLVM10 :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride_preLLVM10 = + [llvmOvr| void @llvm.prefetch( i8*, i32, i32, i32 ) |] + (\_memOps _bak _args -> pure ()) + +llvmFshl :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w ::> BVType w) + (BVType w) +llvmFshl w = + let nm = L.Symbol ("llvm.fshl.i" ++ show (natValue w)) in + [llvmOvr| #w $nm ( #w, #w, #w ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callFshl bak w) args) + +llvmFshr :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w ::> BVType w) + (BVType w) +llvmFshr w = + let nm = L.Symbol ("llvm.fshr.i" ++ show (natValue w)) in + [llvmOvr| #w $nm ( #w, #w, #w ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callFshr bak w) args) + +llvmSaddWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmSaddWithOverflow w = + let nm = L.Symbol ("llvm.sadd.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callSaddWithOverflow bak memOps) args) + +llvmUaddWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmUaddWithOverflow w = + let nm = L.Symbol ("llvm.uadd.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callUaddWithOverflow bak memOps) args) + + +llvmSsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmSsubWithOverflow w = + let nm = L.Symbol ("llvm.ssub.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callSsubWithOverflow bak memOps) args) + + +llvmUsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmUsubWithOverflow w = + let nm = L.Symbol ("llvm.usub.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callUsubWithOverflow bak memOps) args) + +llvmSmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmSmulWithOverflow w = + let nm = L.Symbol ("llvm.smul.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callSmulWithOverflow bak memOps) args) + +llvmUmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (StructType (EmptyCtx ::> BVType w ::> BVType 1)) +llvmUmulWithOverflow w = + let nm = L.Symbol ("llvm.umul.with.overflow.i" ++ show (natValue w)) in + [llvmOvr| { #w, i1 } $nm ( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callUmulWithOverflow bak memOps) args) + +llvmUmax :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (BVType w) +llvmUmax w = + let nm = L.Symbol ("llvm.umax.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callUmax bak memOps) args) + +llvmUmin :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (BVType w) +llvmUmin w = + let nm = L.Symbol ("llvm.umin.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callUmin bak memOps) args) + +llvmSmax :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (BVType w) +llvmSmax w = + let nm = L.Symbol ("llvm.smax.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callSmax bak memOps) args) + +llvmSmin :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType w) + (BVType w) +llvmSmin w = + let nm = L.Symbol ("llvm.smin.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w, #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callSmin bak memOps) args) + +llvmCtlz + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType 1) + (BVType w) +llvmCtlz w = + let nm = L.Symbol ("llvm.ctlz.i" ++ show (natValue w)) in + [llvmOvr| #w $nm ( #w, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callCtlz bak memOps) args) + +llvmCttz + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType 1) + (BVType w) +llvmCttz w = + let nm = L.Symbol ("llvm.cttz.i" ++ show (natValue w)) in + [llvmOvr| #w $nm ( #w, i1 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callCttz bak memOps) args) + +llvmCtpop + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym + (EmptyCtx ::> BVType w) + (BVType w) +llvmCtpop w = + let nm = L.Symbol ("llvm.ctpop.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callCtpop bak memOps) args) + +llvmBitreverse + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym + (EmptyCtx ::> BVType w) + (BVType w) +llvmBitreverse w = + let nm = L.Symbol ("llvm.bitreverse.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callBitreverse bak memOps) args) + +-- | +llvmBSwapOverride + :: forall width sym p + . ( 1 <= width, IsSymInterface sym) + => NatRepr width + -> LLVMOverride p sym + (EmptyCtx ::> BVType (width * 8)) + (BVType (width * 8)) +llvmBSwapOverride widthRepr = + let width8 = natMultiply widthRepr (knownNat @8) + nm = L.Symbol ("llvm.bswap.i" ++ show (widthVal width8)) + in + case mulComm widthRepr (knownNat @8) of { Refl -> + case leqMulMono (knownNat @8) widthRepr :: LeqProof width (width * 8) of { LeqProof -> + case leqTrans (LeqProof :: LeqProof 1 width) + (LeqProof :: LeqProof width (width * 8)) of { LeqProof -> + -- From the LLVM docs: + -- declare i16 @llvm.bswap.i16(i16 ) + [llvmOvr| #width8 $nm( #width8 ) |] + (\_ bak args -> Ctx.uncurryAssignment (Libc.callBSwap bak widthRepr) args) + }}} + +llvmAbsOverride :: + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + NatRepr w -> + LLVMOverride p sym + (EmptyCtx ::> BVType w ::> BVType 1) + (BVType w) +llvmAbsOverride w = + let nm = L.Symbol ("llvm.abs.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w, i1 ) |] + (\mvar bak args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (Libc.callLLVMAbs bak callStack w) args) + +llvmCopysignOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCopysignOverride_F32 = + [llvmOvr| float @llvm.copysign.f32( float, float ) |] + (\_memOpts bak args -> Ctx.uncurryAssignment (callCopysign bak) args) + +llvmCopysignOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCopysignOverride_F64 = + [llvmOvr| double @llvm.copysign.f64( double, double ) |] + (\_memOpts bak args -> Ctx.uncurryAssignment (callCopysign bak) args) + + +llvmFabsF32 + :: forall sym p + . ( IsSymInterface sym) + => LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFabsF32 = + [llvmOvr| float @llvm.fabs.f32( float ) |] + (\_memOps bak (Empty :> (regValue -> x)) -> liftIO (iFloatAbs @_ @SingleFloat (backendGetSym bak) x)) + + +llvmFabsF64 + :: forall sym p + . ( IsSymInterface sym) + => LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFabsF64 = + [llvmOvr| double @llvm.fabs.f64( double ) |] + (\_memOps bak (Empty :> (regValue -> x)) -> liftIO (iFloatAbs @_ @DoubleFloat (backendGetSym bak) x)) + +llvmCeilOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCeilOverride_F32 = + [llvmOvr| float @llvm.ceil.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callCeil bak) args) + +llvmCeilOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCeilOverride_F64 = + [llvmOvr| double @llvm.ceil.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callCeil bak) args) + +llvmFloorOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFloorOverride_F32 = + [llvmOvr| float @llvm.floor.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFloor bak) args) + +llvmFloorOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFloorOverride_F64 = + [llvmOvr| double @llvm.floor.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFloor bak) args) + +llvmSqrtOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSqrtOverride_F32 = + [llvmOvr| float @llvm.sqrt.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSqrt bak) args) + +llvmSqrtOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSqrtOverride_F64 = + [llvmOvr| double @llvm.sqrt.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSqrt bak) args) + +llvmSinOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinOverride_F32 = + [llvmOvr| float @llvm.sin.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Sin) args) + +llvmSinOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinOverride_F64 = + [llvmOvr| double @llvm.sin.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Sin) args) + +llvmCosOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCosOverride_F32 = + [llvmOvr| float @llvm.cos.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Cos) args) + +llvmCosOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCosOverride_F64 = + [llvmOvr| double @llvm.cos.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Cos) args) + +llvmPowOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmPowOverride_F32 = + [llvmOvr| float @llvm.pow.f32( float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 bak W4.Pow) args) + +llvmPowOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmPowOverride_F64 = + [llvmOvr| double @llvm.pow.f64( double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 bak W4.Pow) args) + +llvmExpOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpOverride_F32 = + [llvmOvr| float @llvm.exp.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp) args) + +llvmExpOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpOverride_F64 = + [llvmOvr| double @llvm.exp.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp) args) + +llvmLogOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLogOverride_F32 = + [llvmOvr| float @llvm.log.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log) args) + +llvmLogOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLogOverride_F64 = + [llvmOvr| double @llvm.log.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log) args) + +llvmExp2Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp2Override_F32 = + [llvmOvr| float @llvm.exp2.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp2) args) + +llvmExp2Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp2Override_F64 = + [llvmOvr| double @llvm.exp2.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Exp2) args) + +llvmLog2Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog2Override_F32 = + [llvmOvr| float @llvm.log2.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log2) args) + +llvmLog2Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog2Override_F64 = + [llvmOvr| double @llvm.log2.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log2) args) + +llvmLog10Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog10Override_F32 = + [llvmOvr| float @llvm.log10.f32( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log10) args) + +llvmLog10Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog10Override_F64 = + [llvmOvr| double @llvm.log10.f64( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 bak W4.Log10) args) + +llvmIsFpclassOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat + ::> BVType 32) + (BVType 1) +llvmIsFpclassOverride_F32 = + [llvmOvr| i1 @llvm.is.fpclass.f32( float, i32 ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callIsFpclass bak) args) + +llvmIsFpclassOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat + ::> BVType 32) + (BVType 1) +llvmIsFpclassOverride_F64 = + [llvmOvr| i1 @llvm.is.fpclass.f64( double, i32 ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callIsFpclass bak) args) + +llvmFmaOverride_F32 :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmaOverride_F32 = + [llvmOvr| float @llvm.fma.f32( float, float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args) + +llvmFmaOverride_F64 :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmaOverride_F64 = + [llvmOvr| double @llvm.fma.f64( double, double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args) + +llvmFmuladdOverride_F32 :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmuladdOverride_F32 = + [llvmOvr| float @llvm.fmuladd.f32( float, float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args) + +llvmFmuladdOverride_F64 :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmuladdOverride_F64 = + [llvmOvr| double @llvm.fmuladd.f64( double, double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (Libc.callFMA bak) args) + + +llvmX86_pclmulqdq +--declare <2 x i64> @llvm.x86.pclmulqdq(<2 x i64>, <2 x i64>, i8) #1 + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> VectorType (BVType 64) + ::> VectorType (BVType 64) + ::> BVType 8) + (VectorType (BVType 64)) +llvmX86_pclmulqdq = + [llvmOvr| <2 x i64> @llvm.x86.pclmulqdq(<2 x i64>, <2 x i64>, i8) |] + (\memOps bak args -> Ctx.uncurryAssignment (callX86_pclmulqdq bak memOps) args) + + +llvmX86_SSE2_storeu_dq + :: ( IsSymInterface sym + , HasLLVMAnn sym + , HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> VectorType (BVType 8)) + UnitType +llvmX86_SSE2_storeu_dq = + [llvmOvr| void @llvm.x86.sse2.storeu.dq( i8*, <16 x i8> ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callStoreudq bak memOps) args) + +------------------------------------------------------------------------ +-- ** Implementations + +callX86_pclmulqdq :: forall p sym bak ext wptr r args ret. + (IsSymBackend sym bak, HasPtrWidth wptr) => + bak -> + GlobalVar Mem -> + RegEntry sym (VectorType (BVType 64)) -> + RegEntry sym (VectorType (BVType 64)) -> + RegEntry sym (BVType 8) -> + OverrideSim p sym ext r args ret (RegValue sym (VectorType (BVType 64))) +callX86_pclmulqdq bak _mvar + (regValue -> xs) + (regValue -> ys) + (regValue -> imm) = + do unless (V.length xs == 2) $ + liftIO $ addFailedAssertion bak $ AssertFailureSimError + ("Vector length mismatch in llvm.x86.pclmulqdq intrinsic") + (unwords ["Expected <2 x i64>, but got vector of length", show (V.length xs)]) + unless (V.length ys == 2) $ + liftIO $ addFailedAssertion bak $ AssertFailureSimError + ("Vector length mismatch in llvm.x86.pclmulqdq intrinsic") + (unwords ["Expected <2 x i64>, but got vector of length", show (V.length ys)]) + case BV.asUnsigned <$> asBV imm of + Just byte -> + do let xidx = if byte .&. 0x01 == 0 then 0 else 1 + let yidx = if byte .&. 0x10 == 0 then 0 else 1 + liftIO $ doPcmul (xs V.! xidx) (ys V.! yidx) + _ -> + liftIO $ addFailedAssertion bak $ AssertFailureSimError + ("Illegal selector argument to llvm.x86.pclmulqdq") + (unwords ["Expected concrete value but got", show (printSymExpr imm)]) + where + sym = backendGetSym bak + + doPcmul :: SymBV sym 64 -> SymBV sym 64 -> IO (V.Vector (SymBV sym 64)) + doPcmul x y = + do r <- carrylessMultiply sym x y + lo <- bvTrunc sym (knownNat @64) r + hi <- bvSelect sym (knownNat @64) (knownNat @64) r + -- NB, little endian because X86 + return $ V.fromList [ lo, hi ] + +callStoreudq + :: ( IsSymBackend sym bak + , HasLLVMAnn sym + , HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (VectorType (BVType 8)) + -> OverrideSim p sym ext r args ret () +callStoreudq bak mvar + (regValue -> dest) + (regValue -> vec) = + do mem <- readGlobal mvar + unless (V.length vec == 16) $ + liftIO $ addFailedAssertion bak $ AssertFailureSimError + ("Vector length mismatch in stored_qu intrinsic.") + (unwords ["Expected <16 x i8>, but got vector of length", show (V.length vec)]) + mem' <- liftIO $ doStore + bak + mem + dest + (VectorRepr (KnownBV @8)) + (arrayType 16 (bitvectorType (Bytes 1))) + noAlignment + vec + writeGlobal mvar mem' + + +-- Excerpt from the LLVM documentation: +-- +-- The llvm.objectsize intrinsic is designed to provide information to +-- the optimizers to determine at compile time whether a) an operation +-- (like memcpy) will overflow a buffer that corresponds to an object, +-- or b) that a runtime check for overflow isn’t necessary. An object +-- in this context means an allocation of a specific class, structure, +-- array, or other object. +-- +-- The llvm.objectsize intrinsic takes two arguments. The first +-- argument is a pointer to or into the object. The second argument is +-- a boolean and determines whether llvm.objectsize returns 0 (if +-- true) or -1 (if false) when the object size is unknown. The second +-- argument only accepts constants. +-- +-- The llvm.objectsize intrinsic is lowered to a constant representing +-- the size of the object concerned. If the size cannot be determined +-- at compile time, llvm.objectsize returns i32/i64 -1 or 0 (depending +-- on the min argument). +callObjectsize + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> NatRepr w + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callObjectsize bak _mvar w + (regValue -> _ptr) + (regValue -> flag) = liftIO $ do + let sym = backendGetSym bak + -- Ignore the pointer value, and just return the value for unknown, as + -- defined by the documenatation. If an `objectsize` invocation survives + -- through compilation for us to see, that means the compiler could not + -- determine the value. + t <- bvIsNonzero sym flag + z <- bvLit sym w (BV.zero w) + n <- bvNotBits sym z -- NB: -1 is the boolean negation of zero + bvIte sym t z n + +callObjectsize_null + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> NatRepr w + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 1) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callObjectsize_null bak mvar w ptr flag _nullUnknown = callObjectsize bak mvar w ptr flag + +callObjectsize_null_dynamic + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> NatRepr w + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 1) + -> RegEntry sym (BVType 1) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callObjectsize_null_dynamic bak mvar w ptr flag _nullUnknown (regValue -> dynamic) = + do let sym = backendGetSym bak + liftIO $ + do notDynamic <- notPred sym =<< bvIsNonzero sym dynamic + assert bak notDynamic (AssertFailureSimError "llvm.objectsize called with `dynamic` set to `true`" "") + callObjectsize bak mvar w ptr flag + +callCtlz + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCtlz bak _mvar + (regValue -> val) + (regValue -> isZeroUndef) = liftIO $ + do let sym = backendGetSym bak + isNonzero <- bvIsNonzero sym val + zeroOK <- notPred sym =<< bvIsNonzero sym isZeroUndef + p <- orPred sym isNonzero zeroOK + assert bak p (AssertFailureSimError "Ctlz called with disallowed zero value" "") + bvCountLeadingZeros sym val + +callFshl + :: (1 <= w, IsSymBackend sym bak) + => bak + -> NatRepr w + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callFshl bak w x y amt = liftIO $ + do LeqProof <- return (dblPosIsPos (leqProof (knownNat @1) w)) + Just LeqProof <- return (testLeq (addNat w (knownNat @1)) (addNat w w)) + let sym = backendGetSym bak + + -- concatenate the values together + xy <- bvConcat sym (regValue x) (regValue y) + + -- The shift argument is treated as an unsigned amount modulo the element size of the arguments. + m <- bvLit sym w (BV.width w) + mamt <- bvUrem sym (regValue amt) m + mamt' <- bvZext sym (addNat w w) mamt + + -- shift left, select high bits + z <- bvShl sym xy mamt' + bvSelect sym w w z + +callFshr + :: (1 <= w, IsSymBackend sym bak) + => bak + -> NatRepr w + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callFshr bak w x y amt = liftIO $ + do LeqProof <- return (dblPosIsPos (leqProof (knownNat @1) w)) + LeqProof <- return (addPrefixIsLeq w w) + Just LeqProof <- return (testLeq (addNat w (knownNat @1)) (addNat w w)) + let sym = backendGetSym bak + + -- concatenate the values together + xy <- bvConcat sym (regValue x) (regValue y) + + -- The shift argument is treated as an unsigned amount modulo the element size of the arguments. + m <- bvLit sym w (BV.width w) + mamt <- bvUrem sym (regValue amt) m + mamt' <- bvZext sym (addNat w w) mamt + + -- shift right, select low bits + z <- bvLshr sym xy mamt' + bvSelect sym (knownNat @0) w z + +callSaddWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callSaddWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- addSignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUaddWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callUaddWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- addUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUsubWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callUsubWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- subUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callSsubWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callSsubWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- subSignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callSmulWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callSmulWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- mulSignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUmulWithOverflow + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (StructType (EmptyCtx ::> BVType w ::> BVType 1))) +callUmulWithOverflow bak _mvar + (regValue -> x) + (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + (ov, z) <- mulUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUmax + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callUmax bak _mvar (regValue -> x) (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + xGtY <- bvUgt sym x y + bvIte sym xGtY x y + +callUmin + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callUmin bak _mvar (regValue -> x) (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + xLtY <- bvUlt sym x y + bvIte sym xLtY x y + +callSmax + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callSmax bak _mvar (regValue -> x) (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + xGtY <- bvSgt sym x y + bvIte sym xGtY x y + +callSmin + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callSmin bak _mvar (regValue -> x) (regValue -> y) = liftIO $ + do let sym = backendGetSym bak + xLtY <- bvSlt sym x y + bvIte sym xLtY x y + + +callCttz + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCttz bak _mvar + (regValue -> val) + (regValue -> isZeroUndef) = liftIO $ + do let sym = backendGetSym bak + isNonzero <- bvIsNonzero sym val + zeroOK <- notPred sym =<< bvIsNonzero sym isZeroUndef + p <- orPred sym isNonzero zeroOK + assert bak p (AssertFailureSimError "Cttz called with disallowed zero value" "") + bvCountTrailingZeros sym val + +callCtpop + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCtpop bak _mvar + (regValue -> val) = liftIO $ bvPopcount (backendGetSym bak) val + +callBitreverse + :: (1 <= w, IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callBitreverse bak _mvar + (regValue -> val) = liftIO $ bvBitreverse (backendGetSym bak) val + +-- | Strictly speaking, this doesn't quite conform to the C99 description of +-- @copysign@, since @copysign(NaN, -1.0)@ should return @NaN@ with a negative +-- sign bit. @libBF@ does not provide a way to distinguish between @NaN@ values +-- with different sign bits, however, so @copysign@ will always turn a @NaN@ +-- argument into a positive, \"quiet\" @NaN@. +callCopysign :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak) => + bak -> + RegEntry sym (FloatType fi) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callCopysign bak + (regValue -> x) + (regValue -> y) = liftIO $ do + let sym = backendGetSym bak + xIsNeg <- iFloatIsNeg @_ @fi sym x + yIsNeg <- iFloatIsNeg @_ @fi sym y + signsSame <- eqPred sym xIsNeg yIsNeg + xNegated <- iFloatNeg @_ @fi sym x + iFloatIte @_ @fi sym signsSame x xNegated + +-- | An implementation of the @llvm.is.fpclass@ intrinsic. This essentially +-- combines several different floating-point checks (checking for @NaN@, +-- infinity, zero, etc.) into a single function. The second argument is a +-- bitmask that controls which properties to check of the first argument. +-- The different checks in the bitmask are described by the table here: +-- +-- +-- The specification requires being able to distinguish between signaling +-- @NaN@s (bit 0 of the bitmask) and quit @NaN@s (bit 1 of the bitmask), but +-- @crucible-llvm@ does not have the ability to do this. As a result, both +-- @NaN@ checks will always return true in this implementation, regardless of +-- whether they are signaling or quiet @NaN@s. +callIsFpclass :: + forall fi p sym bak ext r args ret. + IsSymBackend sym bak => + bak -> + RegEntry sym (FloatType fi) -> + RegEntry sym (BVType 32) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType 1)) +callIsFpclass bak regOp@(regValue -> op) (regValue -> test) = do + bvOne <- liftIO $ bvLit sym w1 (BV.one w1) + bvZero <- liftIO $ bvLit sym w1 (BV.zero w1) + + let negative bit = liftIO $ do + isNeg <- iFloatIsNeg @_ @fi sym op + liftIO $ bvIte sym isNeg bit bvZero + + let positive bit = liftIO $ do + isPos <- iFloatIsPos @_ @fi sym op + liftIO $ bvIte sym isPos bit bvZero + + let negAndPos doCheck = liftIO $ do + check <- doCheck + checkN <- negative check + checkP <- positive check + pure (checkN, checkP) + + let callIsInf x = do + isInf <- iFloatIsInf @_ @fi sym x + bvIte sym isInf bvOne bvZero + + let callIsNormal x = do + isNorm <- iFloatIsNorm @_ @fi sym x + bvIte sym isNorm bvOne bvZero + + let callIsSubnormal x = do + isSubnorm <- iFloatIsSubnorm @_ @fi sym x + bvIte sym isSubnorm bvOne bvZero + + let callIsZero x = do + is0 <- iFloatIsZero @_ @fi sym x + bvIte sym is0 bvOne bvZero + + isNan <- Libc.callIsnan bak w1 regOp + (isInfN, isInfP) <- negAndPos $ callIsInf op + (isNormN, isNormP) <- negAndPos $ callIsNormal op + (isSubnormN, isSubnormP) <- negAndPos $ callIsSubnormal op + (isZeroN, isZeroP) <- negAndPos $ callIsZero op + + foldM + (\bits (bitNum, check) -> liftIO $ do + isBitSet <- liftIO $ testBitBV sym bitNum test + newBit <- liftIO $ bvIte sym isBitSet check bvZero + liftIO $ bvOrBits sym newBit bits) + bvZero + [ (0, isNan) -- Signaling NaN + , (1, isNan) -- Quiet NaN + , (2, isInfN) -- Negative infinity + , (3, isNormN) -- Negative normal + , (4, isSubnormN) -- Negative subnormal + , (5, isZeroN) -- Negative zero + , (6, isZeroP) -- Positive zero + , (7, isSubnormP) -- Positive subnormal + , (8, isNormP) -- Positive normal + , (9, isInfP) -- Positive infinity + ] + where + sym = backendGetSym bak + w1 = knownNat @1 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs @@ -0,0 +1,1707 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Libc +-- Description : Override definitions for C standard library functions +-- Copyright : (c) Galois, Inc 2015-2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.Intrinsics.Libc where + +import Control.Lens ((^.), _1, _2, _3) +import qualified Codec.Binary.UTF8.Generic as UTF8 +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State (MonadState(..), StateT(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import qualified Data.ByteString as BS +import qualified Data.Vector as V +import System.IO +import qualified GHC.Stack as GHC + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Context ( pattern (:>), pattern Empty ) +import qualified Data.Parameterized.Context as Ctx + +import What4.Interface +import What4.InterpretedFloatingPoint (IsInterpretedFloatExprBuilder(..)) +import What4.ProgramLoc (plSourceLoc) +import qualified What4.SpecialFunctions as W4 + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common +import Lang.Crucible.Types +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError + +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import qualified Lang.Crucible.LLVM.Errors.Poison as Poison +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.MalformedLLVMModule +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack) +import qualified Lang.Crucible.LLVM.MemModel.Type as G +import qualified Lang.Crucible.LLVM.MemModel.Generic as G +import Lang.Crucible.LLVM.MemModel.Partial +import Lang.Crucible.LLVM.Printf +import Lang.Crucible.LLVM.QQ( llvmOvr ) +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.LLVM.Intrinsics.Common +import Lang.Crucible.LLVM.Intrinsics.Options + +------------------------------------------------------------------------ +-- ** Declarations + + +llvmMemcpyOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemcpyOverride = + [llvmOvr| i8* @memcpy( i8*, i8*, size_t ) |] + (\memOps bak args -> + do volatile <- liftIO $ RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat) + Ctx.uncurryAssignment (callMemcpy bak memOps) + (args :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + + +llvmMemcpyChkOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemcpyChkOverride = + [llvmOvr| i8* @__memcpy_chk ( i8*, i8*, size_t, size_t ) |] + (\memOps bak args -> + do let args' = Empty :> (args^._1) :> (args^._2) :> (args^._3) + volatile <- liftIO $ RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat) + Ctx.uncurryAssignment (callMemcpy bak memOps) + (args' :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + +llvmMemmoveOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> (LLVMPointerType wptr) + ::> (LLVMPointerType wptr) + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemmoveOverride = + [llvmOvr| i8* @memmove( i8*, i8*, size_t ) |] + (\memOps bak args -> + do volatile <- liftIO (RegEntry knownRepr <$> bvLit (backendGetSym bak) knownNat (BV.zero knownNat)) + Ctx.uncurryAssignment (callMemmove bak memOps) + (args :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + +llvmMemsetOverride :: forall p sym wptr. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 32 + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemsetOverride = + [llvmOvr| i8* @memset( i8*, i32, size_t ) |] + (\memOps bak args -> + do let sym = backendGetSym bak + LeqProof <- return (leqTrans @9 @16 @wptr LeqProof LeqProof) + let dest = args^._1 + val <- liftIO (RegEntry knownRepr <$> bvTrunc sym (knownNat @8) (regValue (args^._2))) + let len = args^._3 + volatile <- liftIO + (RegEntry knownRepr <$> bvLit sym knownNat (BV.zero knownNat)) + callMemset bak memOps dest val len volatile + return (regValue dest) + ) + +llvmMemsetChkOverride + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 32 + ::> BVType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemsetChkOverride = + [llvmOvr| i8* @__memset_chk( i8*, i32, size_t, size_t ) |] + (\memOps bak args -> + do let sym = backendGetSym bak + let dest = args^._1 + val <- liftIO + (RegEntry knownRepr <$> bvTrunc sym knownNat (regValue (args^._2))) + let len = args^._3 + volatile <- liftIO + (RegEntry knownRepr <$> bvLit sym knownNat (BV.zero knownNat)) + callMemset bak memOps dest val len volatile + return (regValue dest) + ) + +------------------------------------------------------------------------ +-- *** Allocation + +llvmCallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> BVType wptr ::> BVType wptr) + (LLVMPointerType wptr) +llvmCallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @calloc( size_t, size_t ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callCalloc bak memOps alignment) args) + + +llvmReallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr) + (LLVMPointerType wptr) +llvmReallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @realloc( i8*, size_t ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callRealloc bak memOps alignment) args) + +llvmMallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> BVType wptr) + (LLVMPointerType wptr) +llvmMallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @malloc( size_t ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callMalloc bak memOps alignment) args) + +posixMemalignOverride :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) => + LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType wptr + ::> BVType wptr) + (BVType 32) +posixMemalignOverride = + [llvmOvr| i32 @posix_memalign( i8**, size_t, size_t ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callPosixMemalign bak memOps) args) + + +llvmFreeOverride + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr) + UnitType +llvmFreeOverride = + [llvmOvr| void @free( i8* ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callFree bak memOps) args) + +------------------------------------------------------------------------ +-- *** Strings and I/O + +llvmPrintfOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> VectorType AnyType) + (BVType 32) +llvmPrintfOverride = + [llvmOvr| i32 @printf( i8*, ... ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callPrintf bak memOps) args) + +llvmPrintfChkOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> BVType 32 + ::> LLVMPointerType wptr + ::> VectorType AnyType) + (BVType 32) +llvmPrintfChkOverride = + [llvmOvr| i32 @__printf_chk( i32, i8*, ... ) |] + (\memOps bak args -> Ctx.uncurryAssignment (\_flg -> callPrintf bak memOps) args) + + +llvmPutCharOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym (EmptyCtx ::> BVType 32) (BVType 32) +llvmPutCharOverride = + [llvmOvr| i32 @putchar( i32 ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callPutChar bak memOps) args) + + +llvmPutsOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) (BVType 32) +llvmPutsOverride = + [llvmOvr| i32 @puts( i8* ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callPuts bak memOps) args) + +llvmStrlenOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym (EmptyCtx ::> LLVMPointerType wptr) (BVType wptr) +llvmStrlenOverride = + [llvmOvr| size_t @strlen( i8* ) |] + (\memOps bak args -> Ctx.uncurryAssignment (callStrlen bak memOps) args) + +------------------------------------------------------------------------ +-- ** Implementations + +------------------------------------------------------------------------ +-- *** Allocation + +callRealloc + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> Alignment + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callRealloc bak mvar alignment (regValue -> ptr) (regValue -> sz) = + do let sym = backendGetSym bak + szZero <- liftIO (notPred sym =<< bvIsNonzero sym sz) + ptrNull <- liftIO (ptrIsNull sym PtrWidth ptr) + loc <- liftIO (plSourceLoc <$> getCurrentProgramLoc sym) + let displayString = " " ++ show loc + + symbolicBranches emptyRegMap + -- If the pointer is null, behave like malloc + [ ( ptrNull + , modifyGlobal mvar $ \mem -> liftIO $ doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + , Nothing + ) + + -- If the size is zero, behave like malloc (of zero bytes) then free + , (szZero + , modifyGlobal mvar $ \mem -> liftIO $ + do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + mem2 <- doFree bak mem1 ptr + return (newp, mem2) + , Nothing + ) + + -- Otherwise, allocate a new region, memcopy `sz` bytes and free the old pointer + , (truePred sym + , modifyGlobal mvar $ \mem -> liftIO $ + do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + mem2 <- uncheckedMemcpy sym mem1 newp ptr sz + mem3 <- doFree bak mem2 ptr + return (newp, mem3) + , Nothing) + ] + + +callPosixMemalign + :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPosixMemalign bak mvar (regValue -> outPtr) (regValue -> align) (regValue -> sz) = + let sym = backendGetSym bak in + case asBV align of + Nothing -> fail $ unwords ["posix_memalign: alignment value must be concrete:", show (printSymExpr align)] + Just concrete_align -> + case toAlignment (toBytes (BV.asUnsigned concrete_align)) of + Nothing -> fail $ unwords ["posix_memalign: invalid alignment value:", show concrete_align] + Just a -> + let dl = llvmDataLayout ?lc in + modifyGlobal mvar $ \mem -> liftIO $ + do loc <- plSourceLoc <$> getCurrentProgramLoc sym + let displayString = " " ++ show loc + (p, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz a + mem'' <- storeRaw bak mem' outPtr (bitvectorType (dl^.ptrSize)) (dl^.ptrAlign) (ptrToPtrVal p) + z <- bvLit sym knownNat (BV.zero knownNat) + return (z, mem'') + +callMalloc + :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> Alignment + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callMalloc bak mvar alignment (regValue -> sz) = + modifyGlobal mvar $ \mem -> liftIO $ + do loc <- plSourceLoc <$> getCurrentProgramLoc (backendGetSym bak) + let displayString = " " ++ show loc + doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + +callCalloc + :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> Alignment + -> RegEntry sym (BVType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callCalloc bak mvar alignment + (regValue -> sz) + (regValue -> num) = + modifyGlobal mvar $ \mem -> liftIO $ + doCalloc bak mem sz num alignment + +callFree + :: (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret () +callFree bak mvar + (regValue -> ptr) = + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doFree bak mem ptr + return ((), mem') + +------------------------------------------------------------------------ +-- *** Memory manipulation + +callMemcpy + :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemcpy bak mvar + (regValue -> dest) + (regValue -> src) + (RegEntry (BVRepr w) len) + _volatile = + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemcpy bak w mem True dest src len + return ((), mem') + +-- NB the only difference between memcpy and memove +-- is that memmove does not assert that the memory +-- ranges are disjoint. The underlying operation +-- works correctly in both cases. +callMemmove + :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemmove bak mvar + (regValue -> dest) + (regValue -> src) + (RegEntry (BVRepr w) len) + _volatile = + -- FIXME? add assertions about alignment + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemcpy bak w mem False dest src len + return ((), mem') + +callMemset + :: (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 8) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemset bak mvar + (regValue -> dest) + (regValue -> val) + (RegEntry (BVRepr w) len) + _volatile = + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemset bak w mem dest val len + return ((), mem') + +------------------------------------------------------------------------ +-- *** Strings and I/O + +callPutChar + :: (IsSymBackend sym bak) + => bak + -> GlobalVar Mem + -> RegEntry sym (BVType 32) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPutChar _bak _mvar + (regValue -> ch) = do + h <- printHandle <$> getContext + let chval = maybe '?' (toEnum . fromInteger) (BV.asUnsigned <$> asBV ch) + liftIO $ hPutChar h chval + return ch + +callPuts + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPuts bak mvar + (regValue -> strPtr) = do + mem <- readGlobal mvar + str <- liftIO $ loadString bak mem strPtr Nothing + h <- printHandle <$> getContext + liftIO $ hPutStrLn h (UTF8.toString str) + -- return non-negative value on success + liftIO $ bvLit (backendGetSym bak) knownNat (BV.one knownNat) + +callStrlen + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr)) +callStrlen bak mvar (regValue -> strPtr) = do + mem <- readGlobal mvar + liftIO $ strLen bak mem strPtr + +callAssert + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => Bool -- ^ 'True' if this is @__assert_fail()@, 'False' otherwise. + -> GlobalVar Mem + -> bak + -> Ctx.Assignment (RegEntry sym) + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + -> forall r args reg. + OverrideSim p sym ext r args reg (RegValue sym UnitType) +callAssert assert_fail mvar bak (Empty :> _pfn :> _pfile :> _pline :> ptxt ) = + do let sym = backendGetSym bak + when failUponExit $ + do mem <- readGlobal mvar + txt <- liftIO $ loadString bak mem (regValue ptxt) Nothing + let err = AssertFailureSimError "Call to assert()" (UTF8.toString txt) + liftIO $ addFailedAssertion bak err + liftIO $ + do loc <- liftIO $ getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + where + failUponExit :: Bool + failUponExit + | assert_fail + = abnormalExitBehavior ?intrinsicsOpts `elem` [AlwaysFail, OnlyAssertFail] + | otherwise + = abnormalExitBehavior ?intrinsicsOpts == AlwaysFail + +callExit :: ( IsSymBackend sym bak + , ?intrinsicsOpts :: IntrinsicsOptions ) + => bak + -> RegEntry sym (BVType 32) + -> OverrideSim p sym ext r args ret (RegValue sym UnitType) +callExit bak ec = liftIO $ + do let sym = backendGetSym bak + when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $ + do cond <- bvEq sym (regValue ec) =<< bvLit sym knownNat (BV.zero knownNat) + -- If the argument is non-zero, throw an assertion failure. Otherwise, + -- simply stop the current thread of execution. + assert bak cond "Call to exit() with non-zero argument" + loc <- getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + +callPrintf + :: ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (VectorType AnyType) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPrintf bak mvar + (regValue -> strPtr) + (regValue -> valist) = do + mem <- readGlobal mvar + formatStr <- liftIO $ loadString bak mem strPtr Nothing + case parseDirectives formatStr of + Left err -> overrideError $ AssertFailureSimError "Format string parsing failed" err + Right ds -> do + ((str, n), mem') <- liftIO $ runStateT (executeDirectives (printfOps bak valist) ds) mem + writeGlobal mvar mem' + h <- printHandle <$> getContext + liftIO $ BS.hPutStr h str + liftIO $ bvLit (backendGetSym bak) knownNat (BV.mkBV knownNat (toInteger n)) + +printfOps :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> V.Vector (AnyValue sym) + -> PrintfOperations (StateT (MemImpl sym) IO) +printfOps bak valist = + let sym = backendGetSym bak in + PrintfOperations + { printfUnsupported = \x -> lift $ addFailedAssertion bak + $ Unsupported GHC.callStack x + + , printfGetInteger = \i sgn _len -> + case valist V.!? (i-1) of + Just (AnyValue (LLVMPointerRepr w) x) -> + do bv <- liftIO (projectLLVM_bv bak x) + if sgn then + return $ BV.asSigned w <$> asBV bv + else + return $ BV.asUnsigned <$> asBV bv + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf" + (unwords ["Expected integer, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf" + (unwords ["Index:", show i]) + + , printfGetFloat = \i _len -> + case valist V.!? (i-1) of + Just (AnyValue (FloatRepr (_fi :: FloatInfoRepr fi)) x) -> + do xr <- liftIO (iFloatToReal @_ @fi sym x) + return (asRational xr) + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected floating-point, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfGetString = \i numchars -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + do mem <- get + liftIO $ loadString bak mem ptr numchars + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected char*, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfGetPointer = \i -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + return $ show (G.ppPtr ptr) + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected void*, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfSetInteger = \i len v -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + do mem <- get + case len of + Len_Byte -> do + let w8 = knownNat :: NatRepr 8 + let tp = G.bitvectorType 1 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w8 (BV.mkBV w8 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w8) tp noAlignment x + put mem' + Len_Short -> do + let w16 = knownNat :: NatRepr 16 + let tp = G.bitvectorType 2 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w16 (BV.mkBV w16 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w16) tp noAlignment x + put mem' + Len_NoMod -> do + let w32 = knownNat :: NatRepr 32 + let tp = G.bitvectorType 4 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w32 (BV.mkBV w32 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w32) tp noAlignment x + put mem' + Len_Long -> do + let w64 = knownNat :: NatRepr 64 + let tp = G.bitvectorType 8 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w64 (BV.mkBV w64 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w64) tp noAlignment x + put mem' + _ -> + lift $ addFailedAssertion bak + $ Unsupported GHC.callStack + $ unwords ["Unsupported size modifier in %n conversion:", show len] + + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected void*, but got:", show tpr]) + + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + } + +------------------------------------------------------------------------ +-- *** Math + +llvmCeilOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCeilOverride = + [llvmOvr| double @ceil( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callCeil sym) args) + +llvmCeilfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCeilfOverride = + [llvmOvr| float @ceilf( float ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callCeil sym) args) + + +llvmFloorOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFloorOverride = + [llvmOvr| double @floor( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callFloor sym) args) + +llvmFloorfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFloorfOverride = + [llvmOvr| float @floorf( float ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callFloor sym) args) + +llvmFmafOverride :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmafOverride = + [llvmOvr| float @fmaf( float, float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callFMA bak) args) + +llvmFmaOverride :: + forall sym p + . IsSymInterface sym + => LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmaOverride = + [llvmOvr| double @fma( double, double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callFMA bak) args) + + +-- math.h defines isinf() and isnan() as macros, so you might think it unusual +-- to provide function overrides for them. However, if you write, say, +-- (isnan)(x) instead of isnan(x), Clang will compile the former as a direct +-- function call rather than as a macro application. Some experimentation +-- reveals that the isnan function's argument is always a double, so we give its +-- argument the type double here to match this unstated convention. We follow +-- suit similarly with isinf. +-- +-- Clang does not yet provide direct function call versions of isfinite() or +-- isnormal(), so we do not provide overrides for them. + +llvmIsinfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvmIsinfOverride = + [llvmOvr| i32 @isinf( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args) + +-- __isinf and __isinff are like the isinf macro, except their arguments are +-- known to be double or float, respectively. They are not mentioned in the +-- POSIX source standard, only the binary standard. See +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinf.html and +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinff.html. +llvm__isinfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvm__isinfOverride = + [llvmOvr| i32 @__isinf( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args) + +llvm__isinffOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (BVType 32) +llvm__isinffOverride = + [llvmOvr| i32 @__isinff( float ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsinf sym (knownNat @32)) args) + +llvmIsnanOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvmIsnanOverride = + [llvmOvr| i32 @isnan( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args) + +-- __isnan and __isnanf are like the isnan macro, except their arguments are +-- known to be double or float, respectively. They are not mentioned in the +-- POSIX source standard, only the binary standard. See +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnan.html and +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnanf.html. +llvm__isnanOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvm__isnanOverride = + [llvmOvr| i32 @__isnan( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args) + +llvm__isnanfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (BVType 32) +llvm__isnanfOverride = + [llvmOvr| i32 @__isnanf( float ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callIsnan sym (knownNat @32)) args) + + +llvmSqrtOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSqrtOverride = + [llvmOvr| double @sqrt( double ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callSqrt sym) args) + +llvmSqrtfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSqrtfOverride = + [llvmOvr| float @sqrtf( float ) |] + (\_memOps sym args -> Ctx.uncurryAssignment (callSqrt sym) args) + +callSpecialFunction1 :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak, KnownRepr FloatInfoRepr fi) => + bak -> + W4.SpecialFunction (EmptyCtx ::> W4.R) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSpecialFunction1 bak fn (regValue -> x) = liftIO $ + iFloatSpecialFunction1 (backendGetSym bak) (knownRepr :: FloatInfoRepr fi) fn x + +callSpecialFunction2 :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak, KnownRepr FloatInfoRepr fi) => + bak -> + W4.SpecialFunction (EmptyCtx ::> W4.R ::> W4.R) -> + RegEntry sym (FloatType fi) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSpecialFunction2 bak fn (regValue -> x) (regValue -> y) = liftIO $ + iFloatSpecialFunction2 (backendGetSym bak) (knownRepr :: FloatInfoRepr fi) fn x y + +callCeil :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak) => + bak -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callCeil bak (regValue -> x) = liftIO $ iFloatRound @_ @fi (backendGetSym bak) RTP x + +callFloor :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak) => + bak -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callFloor bak (regValue -> x) = liftIO $ iFloatRound @_ @fi (backendGetSym bak) RTN x + +-- | An implementation of @libc@'s @fma@ function. +callFMA :: + forall fi p sym bak ext r args ret + . IsSymBackend sym bak + => bak + -> RegEntry sym (FloatType fi) + -> RegEntry sym (FloatType fi) + -> RegEntry sym (FloatType fi) + -> OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callFMA bak (regValue -> x) (regValue -> y) (regValue -> z) = liftIO $ + iFloatFMA @_ @fi (backendGetSym bak) defaultRM x y z + +-- | An implementation of @libc@'s @isinf@ macro. This returns @1@ when the +-- argument is positive infinity, @-1@ when the argument is negative infinity, +-- and zero otherwise. +callIsinf :: + forall fi w p sym bak ext r args ret. + (IsSymBackend sym bak, 1 <= w) => + bak -> + NatRepr w -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callIsinf bak w (regValue -> x) = liftIO $ do + let sym = backendGetSym bak + isInf <- iFloatIsInf @_ @fi sym x + isNeg <- iFloatIsNeg @_ @fi sym x + isPos <- iFloatIsPos @_ @fi sym x + isInfN <- andPred sym isInf isNeg + isInfP <- andPred sym isInf isPos + bvOne <- bvLit sym w (BV.one w) + bvNegOne <- bvNeg sym bvOne + bvZero <- bvLit sym w (BV.zero w) + res0 <- bvIte sym isInfP bvOne bvZero + bvIte sym isInfN bvNegOne res0 + +callIsnan :: + forall fi w p sym bak ext r args ret. + (IsSymBackend sym bak, 1 <= w) => + bak -> + NatRepr w -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callIsnan bak w (regValue -> x) = liftIO $ do + let sym = backendGetSym bak + isnan <- iFloatIsNaN @_ @fi sym x + bvOne <- bvLit sym w (BV.one w) + bvZero <- bvLit sym w (BV.zero w) + -- isnan() is allowed to return any nonzero value if the argument is NaN, and + -- out of all the possible nonzero values, `1` is certainly one of them. + bvIte sym isnan bvOne bvZero + +callSqrt :: + forall fi p sym bak ext r args ret. + (IsSymBackend sym bak) => + bak -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSqrt bak (regValue -> x) = liftIO $ iFloatSqrt @_ @fi (backendGetSym bak) defaultRM x + +------------------------------------------------------------------------ +-- **** Circular trigonometry functions + +-- sin(f) + +llvmSinOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinOverride = + [llvmOvr| double @sin( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sin) args) + +llvmSinfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinfOverride = + [llvmOvr| float @sinf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sin) args) + +-- cos(f) + +llvmCosOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCosOverride = + [llvmOvr| double @cos( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cos) args) + +llvmCosfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCosfOverride = + [llvmOvr| float @cosf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cos) args) + +-- tan(f) + +llvmTanOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmTanOverride = + [llvmOvr| double @tan( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tan) args) + +llvmTanfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmTanfOverride = + [llvmOvr| float @tanf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tan) args) + +-- asin(f) + +llvmAsinOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAsinOverride = + [llvmOvr| double @asin( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsin) args) + +llvmAsinfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAsinfOverride = + [llvmOvr| float @asinf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsin) args) + +-- acos(f) + +llvmAcosOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAcosOverride = + [llvmOvr| double @acos( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccos) args) + +llvmAcosfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAcosfOverride = + [llvmOvr| float @acosf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccos) args) + +-- atan(f) + +llvmAtanOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtanOverride = + [llvmOvr| double @atan( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctan) args) + +llvmAtanfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtanfOverride = + [llvmOvr| float @atanf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctan) args) + +------------------------------------------------------------------------ +-- **** Hyperbolic trigonometry functions + +-- sinh(f) + +llvmSinhOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinhOverride = + [llvmOvr| double @sinh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sinh) args) + +llvmSinhfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinhfOverride = + [llvmOvr| float @sinhf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Sinh) args) + +-- cosh(f) + +llvmCoshOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCoshOverride = + [llvmOvr| double @cosh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cosh) args) + +llvmCoshfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCoshfOverride = + [llvmOvr| float @coshf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Cosh) args) + +-- tanh(f) + +llvmTanhOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmTanhOverride = + [llvmOvr| double @tanh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tanh) args) + +llvmTanhfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmTanhfOverride = + [llvmOvr| float @tanhf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Tanh) args) + +-- asinh(f) + +llvmAsinhOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAsinhOverride = + [llvmOvr| double @asinh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsinh) args) + +llvmAsinhfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAsinhfOverride = + [llvmOvr| float @asinhf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arcsinh) args) + +-- acosh(f) + +llvmAcoshOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAcoshOverride = + [llvmOvr| double @acosh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccosh) args) + +llvmAcoshfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAcoshfOverride = + [llvmOvr| float @acoshf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arccosh) args) + +-- atanh(f) + +llvmAtanhOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtanhOverride = + [llvmOvr| double @atanh( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctanh) args) + +llvmAtanhfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtanhfOverride = + [llvmOvr| float @atanhf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Arctanh) args) + +------------------------------------------------------------------------ +-- **** Rectangular to polar coordinate conversion + +-- hypot(f) + +llvmHypotOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmHypotOverride = + [llvmOvr| double @hypot( double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Hypot) args) + +llvmHypotfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmHypotfOverride = + [llvmOvr| float @hypotf( float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Hypot) args) + +-- atan2(f) + +llvmAtan2Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtan2Override = + [llvmOvr| double @atan2( double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Arctan2) args) + +llvmAtan2fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtan2fOverride = + [llvmOvr| float @atan2f( float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Arctan2) args) + +------------------------------------------------------------------------ +-- **** Exponential and logarithm functions + +-- pow(f) + +llvmPowfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmPowfOverride = + [llvmOvr| float @powf( float, float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Pow) args) + +llvmPowOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmPowOverride = + [llvmOvr| double @pow( double, double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction2 bak W4.Pow) args) + +-- exp(f) + +llvmExpOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpOverride = + [llvmOvr| double @exp( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp) args) + +llvmExpfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpfOverride = + [llvmOvr| float @expf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp) args) + +-- log(f) + +llvmLogOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLogOverride = + [llvmOvr| double @log( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log) args) + +llvmLogfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLogfOverride = + [llvmOvr| float @logf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log) args) + +-- expm1(f) + +llvmExpm1Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpm1Override = + [llvmOvr| double @expm1( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Expm1) args) + +llvmExpm1fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpm1fOverride = + [llvmOvr| float @expm1f( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Expm1) args) + +-- log1p(f) + +llvmLog1pOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog1pOverride = + [llvmOvr| double @log1p( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log1p) args) + +llvmLog1pfOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog1pfOverride = + [llvmOvr| float @log1pf( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log1p) args) + +------------------------------------------------------------------------ +-- **** Base 2 exponential and logarithm + +-- exp2(f) + +llvmExp2Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp2Override = + [llvmOvr| double @exp2( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp2) args) + +llvmExp2fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp2fOverride = + [llvmOvr| float @exp2f( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp2) args) + +-- log2(f) + +llvmLog2Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog2Override = + [llvmOvr| double @log2( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log2) args) + +llvmLog2fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog2fOverride = + [llvmOvr| float @log2f( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log2) args) + +------------------------------------------------------------------------ +-- **** Base 10 exponential and logarithm + +-- exp10(f) + +llvmExp10Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp10Override = + [llvmOvr| double @exp10( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp10) args) + +llvmExp10fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp10fOverride = + [llvmOvr| float @exp10f( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Exp10) args) + +-- log10(f) + +llvmLog10Override :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog10Override = + [llvmOvr| double @log10( double ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log10) args) + +llvmLog10fOverride :: + IsSymInterface sym => + LLVMOverride p sym + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog10fOverride = + [llvmOvr| float @log10f( float ) |] + (\_memOps bak args -> Ctx.uncurryAssignment (callSpecialFunction1 bak W4.Log10) args) + +------------------------------------------------------------------------ +-- *** Other + +-- from OSX libc +llvmAssertRtnOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + UnitType +llvmAssertRtnOverride = + [llvmOvr| void @__assert_rtn( i8*, i8*, i32, i8* ) |] + (callAssert False) + +-- From glibc +llvmAssertFailOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + UnitType +llvmAssertFailOverride = + [llvmOvr| void @__assert_fail( i8*, i8*, i32, i8* ) |] + (callAssert True) + + +llvmAbortOverride + :: ( IsSymInterface sym + , ?intrinsicsOpts :: IntrinsicsOptions ) + => LLVMOverride p sym EmptyCtx UnitType +llvmAbortOverride = + [llvmOvr| void @abort() |] + (\_ bak _args -> liftIO $ + do let sym = backendGetSym bak + when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $ + let err = AssertFailureSimError "Call to abort" "" in + assert bak (falsePred sym) err + loc <- getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + ) + +llvmExitOverride + :: forall sym p + . ( IsSymInterface sym + , ?intrinsicsOpts :: IntrinsicsOptions ) + => LLVMOverride p sym + (EmptyCtx ::> BVType 32) + UnitType +llvmExitOverride = + [llvmOvr| void @exit( i32 ) |] + (\_ bak args -> Ctx.uncurryAssignment (callExit bak) args) + +llvmGetenvOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr) + (LLVMPointerType wptr) +llvmGetenvOverride = + [llvmOvr| i8* @getenv( i8* ) |] + (\_ bak _args -> liftIO $ mkNullPointer (backendGetSym bak) PtrWidth) + +llvmHtonlOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmHtonlOverride = + [llvmOvr| i32 @htonl( i32 ) |] + (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @4)) args) + +llvmHtonsOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym + (EmptyCtx ::> BVType 16) + (BVType 16) +llvmHtonsOverride = + [llvmOvr| i16 @htons( i16 ) |] + (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @2)) args) + +llvmNtohlOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmNtohlOverride = + [llvmOvr| i32 @ntohl( i32 ) |] + (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @4)) args) + +llvmNtohsOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym + (EmptyCtx ::> BVType 16) + (BVType 16) +llvmNtohsOverride = + [llvmOvr| i16 @ntohs( i16 ) |] + (\_ bak args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian bak (knownNat @2)) args) + +llvmAbsOverride :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmAbsOverride = + [llvmOvr| i32 @abs( i32 ) |] + (\mvar bak args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @32)) args) + +-- @labs@ uses `long` as its argument and result type, so we need two overrides +-- for @labs@. See Note [Overrides involving (unsigned) long] in +-- Lang.Crucible.LLVM.Intrinsics. +llvmLAbsOverride_32 :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmLAbsOverride_32 = + [llvmOvr| i32 @labs( i32 ) |] + (\mvar bak args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @32)) args) + +llvmLAbsOverride_64 :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym + (EmptyCtx ::> BVType 64) + (BVType 64) +llvmLAbsOverride_64 = + [llvmOvr| i64 @labs( i64 ) |] + (\mvar bak args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @64)) args) + +llvmLLAbsOverride :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym + (EmptyCtx ::> BVType 64) + (BVType 64) +llvmLLAbsOverride = + [llvmOvr| i64 @llabs( i64 ) |] + (\mvar bak args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs bak callStack (knownNat @64)) args) + +callBSwap :: + (1 <= width, IsSymBackend sym bak) => + bak -> + NatRepr width -> + RegEntry sym (BVType (width * 8)) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8))) +callBSwap bak widthRepr (regValue -> vec) = + liftIO $ bvSwap (backendGetSym bak) widthRepr vec + +-- | This determines under what circumstances @callAbs@ should check if its +-- argument is equal to the smallest signed integer of a particular size +-- (e.g., @INT_MIN@), and if it is equal to that value, what kind of error +-- should be reported. +data CheckAbsIntMin + = LibcAbsIntMinUB + -- ^ For the @abs@, @labs@, and @llabs@ functions, always check if the + -- argument is equal to @INT_MIN@. If so, report it as undefined + -- behavior per the C standard. + | LLVMAbsIntMinPoison Bool + -- ^ For the @llvm.abs.*@ family of LLVM intrinsics, check if the argument + -- is equal to @INT_MIN@ only when the 'Bool' argument is 'True'. If it + -- is 'True' and the argument is equal to @INT_MIN@, return poison. + +-- | The workhorse for the @abs@, @labs@, and @llabs@ functions, as well as the +-- @llvm.abs.*@ family of overloaded intrinsics. +callAbs :: + forall w p sym bak ext r args ret. + (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) => + bak -> + CallStack -> + CheckAbsIntMin -> + NatRepr w -> + RegEntry sym (BVType w) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callAbs bak callStack checkIntMin widthRepr (regValue -> src) = liftIO $ do + let sym = backendGetSym bak + bvIntMin <- bvLit sym widthRepr (BV.minSigned widthRepr) + isNotIntMin <- notPred sym =<< bvEq sym src bvIntMin + + when shouldCheckIntMin $ do + isNotIntMinUB <- annotateUB sym callStack ub isNotIntMin + let err = AssertFailureSimError "Undefined behavior encountered" $ + show $ UB.explain ub + assert bak isNotIntMinUB err + + isSrcNegative <- bvIsNeg sym src + srcNegated <- bvNeg sym src + bvIte sym isSrcNegative srcNegated src + where + shouldCheckIntMin :: Bool + shouldCheckIntMin = + case checkIntMin of + LibcAbsIntMinUB -> True + LLVMAbsIntMinPoison shouldCheck -> shouldCheck + + ub :: UB.UndefinedBehavior (RegValue' sym) + ub = case checkIntMin of + LibcAbsIntMinUB -> + UB.AbsIntMin $ RV src + LLVMAbsIntMinPoison{} -> + UB.PoisonValueCreated $ Poison.LLVMAbsIntMin $ RV src + +callLibcAbs :: + (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) => + bak -> + CallStack -> + NatRepr w -> + RegEntry sym (BVType w) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callLibcAbs bak callStack = callAbs bak callStack LibcAbsIntMinUB + +callLLVMAbs :: + (1 <= w, IsSymBackend sym bak, HasLLVMAnn sym) => + bak -> + CallStack -> + NatRepr w -> + RegEntry sym (BVType w) -> + RegEntry sym (BVType 1) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callLLVMAbs bak callStack widthRepr src (regValue -> isIntMinPoison) = do + shouldCheckIntMin <- liftIO $ + -- Per https://releases.llvm.org/12.0.0/docs/LangRef.html#id451, the second + -- argument must be a constant. + case asBV isIntMinPoison of + Just bv -> pure (bv /= BV.zero (knownNat @1)) + Nothing -> malformedLLVMModule + "Call to llvm.abs.* with non-constant second argument" + [printSymExpr isIntMinPoison] + callAbs bak callStack (LLVMAbsIntMinPoison shouldCheckIntMin) widthRepr src + +-- | If the data layout is little-endian, run 'callBSwap' on the input. +-- Otherwise, return the input unchanged. This is the workhorse for the +-- @hton{s,l}@ and @ntoh{s,l}@ overrides. +callBSwapIfLittleEndian :: + (1 <= width, IsSymBackend sym bak, ?lc :: TypeContext) => + bak -> + NatRepr width -> + RegEntry sym (BVType (width * 8)) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8))) +callBSwapIfLittleEndian bak widthRepr vec = + case (llvmDataLayout ?lc)^.intLayout of + BigEndian -> pure (regValue vec) + LittleEndian -> callBSwap bak widthRepr vec + +---------------------------------------------------------------------------- +-- atexit stuff + +cxa_atexitOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> LLVMPointerType wptr) + (BVType 32) +cxa_atexitOverride = + [llvmOvr| i32 @__cxa_atexit( void (i8*)*, i8*, i8* ) |] + (\_ bak _args -> liftIO $ bvLit (backendGetSym bak) knownNat (BV.zero knownNat)) + +---------------------------------------------------------------------------- + +-- | IEEE 754 declares 'RNE' to be the default rounding mode, and most @libc@ +-- implementations agree with this in practice. The only places where we do not +-- use this as the default are operations that specifically require the behavior +-- of a particular rounding mode, such as @ceil@ or @floor@. +defaultRM :: RoundingMode +defaultRM = RNE diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs @@ -0,0 +1,301 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Libcxx +-- Description : Override definitions for C++ standard library functions +-- Copyright : (c) Galois, Inc 2015-2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.Intrinsics.Libcxx + ( register_cpp_override + -- ** iostream + , putToOverride12 + , putToOverride9 + , endlOverride + , sentryOverride + , sentryBoolOverride + ) where + +import qualified ABI.Itanium as ABI +import Control.Applicative (empty) +import Control.Lens ((^.)) +import Control.Monad.Reader +import Data.List (isInfixOf) +import Data.Type.Equality ((:~:)(Refl), testEquality) +import qualified Text.LLVM.AST as L + +import qualified Data.BitVector.Sized as BV +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr (knownNat) + +import What4.Interface (bvLit, natLit) + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.Simulator.RegMap (RegValue, regValue) +import Lang.Crucible.Panic (panic) +import Lang.Crucible.Types (TypeRepr(UnitRepr), CtxRepr) + +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.Intrinsics.Common +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Types + +------------------------------------------------------------------------ +-- ** General + +-- | C++ overrides generally have a bit more work to do: their types are more +-- complex, their names are mangled in the LLVM module, it's a big mess. +register_cpp_override :: + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + SomeCPPOverride p sym arch -> + OverrideTemplate p sym arch rtp l a +register_cpp_override someCPPOverride = + OverrideTemplate (SubstringsMatch ("_Z" : cppOverrideSubstrings someCPPOverride)) $ + do (requestedDecl, decName, llvmctx) <- ask + case decName of + Nothing -> empty + Just nm -> + case cppOverrideAction someCPPOverride requestedDecl nm llvmctx of + Nothing -> empty + Just (SomeLLVMOverride override) -> register_llvm_override override + + +-- type CPPOverride p sym arch args ret = +-- L.Declare -> LLVMContext arch -> Maybe (LLVMOverride p sym arch args ret) + +-- | We can only tell whether we should install a C++ override after demangling +-- the function name, which is expensive. As a first approximation, we ask whether +-- the function's name contains a few substrings, in order. +data SomeCPPOverride p sym arch = + SomeCPPOverride + { cppOverrideSubstrings :: [String] + , cppOverrideAction :: L.Declare -> ABI.DecodedName -> LLVMContext arch -> Maybe (SomeLLVMOverride p sym) + } + +------------------------------------------------------------------------ +-- ** No-ops + +------------------------------------------------------------------------ +-- *** Utilities + +matchSymbolName :: (L.Symbol -> ABI.DecodedName -> Bool) + -> L.Declare + -> ABI.DecodedName + -> Maybe a + -> Maybe a +matchSymbolName match decl decodedName = + if not (match (L.decName decl) decodedName) + then const Nothing + else id + +panic_ :: (Show a, Show b) + => String + -> L.Declare + -> a + -> b + -> c +panic_ from decl args ret = + panic from [ "Ill-typed override" + , "Name: " ++ nm + , "Args: " ++ show args + , "Ret: " ++ show ret + ] + where L.Symbol nm = L.decName decl + +-- | If the requested declaration's symbol matches the filter, look up its +-- function handle in the symbol table and use that to construct an override +mkOverride :: (IsSymInterface sym, HasPtrWidth (ArchWidth arch)) + => [String] -- ^ Substrings for name filtering + -> (forall args ret. L.Declare -> CtxRepr args -> TypeRepr ret -> Maybe (SomeLLVMOverride p sym)) + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +mkOverride substrings ov filt = + SomeCPPOverride substrings $ \requestedDecl decodedName llvmctx -> + let ?lc = llvmctx^.llvmTypeCtx in + matchSymbolName filt requestedDecl decodedName $ + llvmDeclToFunHandleRepr' requestedDecl $ \argTys retTy -> + ov requestedDecl argTys retTy + +------------------------------------------------------------------------ +-- *** No-op override builders + +-- | Make an override for a function which doesn't return anything. +voidOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => [String] + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +voidOverride substrings = + mkOverride substrings $ \decl argTys retTy -> Just $ + case retTy of + UnitRepr -> SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym _args -> pure () + _ -> panic_ "voidOverride" decl argTys retTy + +-- | Make an override for a function of (LLVM) type @a -> a@, for any @a@. +-- +-- The override simply returns its input. +identityOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => [String] + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +identityOverride substrings = + mkOverride substrings $ \decl argTys retTy -> Just $ + case argTys of + (Ctx.Empty Ctx.:> argTy) + | Just Refl <- testEquality argTy retTy -> + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args -> + -- Just return the input + pure (Ctx.uncurryAssignment regValue args) + + _ -> panic_ "identityOverride" decl argTys retTy + +-- | Make an override for a function of (LLVM) type @a -> b -> a@, for any @a@. +-- +-- The override simply returns its first input. +constOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => [String] + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +constOverride substrings = + mkOverride substrings $ \decl argTys retTy -> Just $ + case argTys of + (Ctx.Empty Ctx.:> fstTy Ctx.:> _) + | Just Refl <- testEquality fstTy retTy -> + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args -> + pure (Ctx.uncurryAssignment (const . regValue) args) + + _ -> panic_ "constOverride" decl argTys retTy + +-- | Make an override that always returns the same value. +fixedOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => TypeRepr ty + -> (GlobalVar Mem -> sym -> IO (RegValue sym ty)) + -> [String] + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +fixedOverride ty regval substrings = + mkOverride substrings $ \decl argTys retTy -> Just $ + case testEquality retTy ty of + Just Refl -> + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \mem bak _args -> + liftIO (regval mem (backendGetSym bak)) + + _ -> panic_ "fixedOverride" decl argTys retTy + +-- | Return @true@. +trueOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => [String] + -> (L.Symbol -> ABI.DecodedName -> Bool) + -> SomeCPPOverride p sym arch +trueOverride = + fixedOverride (LLVMPointerRepr knownNat) $ \_mem sym -> + LLVMPointer <$> natLit sym 0 <*> bvLit sym (knownNat @1) (BV.one knownNat) + +------------------------------------------------------------------------ +-- ** Declarations + +------------------------------------------------------------------------ +-- *** iostream + +------------------------------------------------------------------------ +-- **** basic_ostream + +-- | Override for the \"put to\" operator, @<<@ +-- +-- This is the override for the 12th function signature listed here: +-- https://en.cppreference.com/w/cpp/io/basic_ostream/operator_ltlt +putToOverride12 :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => SomeCPPOverride p sym arch +putToOverride12 = + constOverride ["St","ls","basic_ostream"] $ \_ decodedName -> + case decodedName of + ABI.Function + (ABI.NestedName + [] + [ ABI.SubstitutionPrefix ABI.SubStdNamespace + , _ + , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream") + , ABI.TemplateArgsPrefix _ + ] + (ABI.OperatorName ABI.OpShl)) + [ABI.PointerToType (ABI.FunctionType _)] -> True + _ -> False + +-- | Override for the \"put to\" operator, @<<@ +-- +-- This is the override for the 9th function signature listed here (I think): +-- https://en.cppreference.com/w/cpp/io/basic_ostream/operator_ltlt +putToOverride9 :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => SomeCPPOverride p sym arch +putToOverride9 = + constOverride ["NSt3__1lsINS_11char_traitsIcEEEERNS_13basic_ostreamIcT_EES6_PKc"] $ \(L.Symbol nm) _ -> + nm == "_ZNSt3__1lsINS_11char_traitsIcEEEERNS_13basic_ostreamIcT_EES6_PKc" + +-- | TODO: When @itanium-abi@ get support for parsing templates, make this a +-- more structured match +endlOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => SomeCPPOverride p sym arch +endlOverride = + identityOverride ["endl","char_traits","basic_ostream"] $ \(L.Symbol nm) _decodedName -> + and [ "endl" `isInfixOf` nm + , "char_traits" `isInfixOf` nm + , "basic_ostream" `isInfixOf` nm + ] + +sentryOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => SomeCPPOverride p sym arch +sentryOverride = + voidOverride ["basic_ostream", "sentry"] $ \_nm decodedName -> + case decodedName of + ABI.Function + (ABI.NestedName + [] + [ ABI.SubstitutionPrefix ABI.SubStdNamespace + , _ + , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream") + , _ + , ABI.UnqualifiedPrefix (ABI.SourceName "sentry") + ] + _) + _ -> True + _ -> False + +-- | An override of the @bool@ operator (cast) on the @sentry@ class, +-- +-- @sentry::operator bool()@ +sentryBoolOverride :: (IsSymInterface sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) + => SomeCPPOverride p sym arch +sentryBoolOverride = + trueOverride ["basic_ostream", "sentry"] $ \_nm decodedName -> + case decodedName of + ABI.Function + (ABI.NestedName + [ABI.Const] + [ ABI.SubstitutionPrefix ABI.SubStdNamespace + , _ + , ABI.UnqualifiedPrefix (ABI.SourceName "basic_ostream") + , _ + , ABI.UnqualifiedPrefix (ABI.SourceName "sentry") + ] + (ABI.OperatorName (ABI.OpCast ABI.BoolType))) + [ABI.VoidType] -> True + _ -> False diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Options.hs b/src/Lang/Crucible/LLVM/Intrinsics/Options.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Options.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Options +-- Description : Definition of options that affect LLVM overrides +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +module Lang.Crucible.LLVM.Intrinsics.Options + ( IntrinsicsOptions(..) + , AbnormalExitBehavior(..) + , defaultIntrinsicsOptions + ) where + +-- | Should Crucible fail when simulating a function which triggers an abnormal +-- exit, such as @abort()@? +data AbnormalExitBehavior + = AlwaysFail + -- ^ Functions which trigger an abnormal exit will always cause Crucible + -- to fail. + | OnlyAssertFail + -- ^ The @__assert_fail()@ function will cause Crucible to fail, while + -- other functions which triggern an abnormal exit will not cause + -- failures. This option is primarily useful for SV-COMP. + | NeverFail + -- ^ Functions which trigger an abnormal exit will never cause Crucible + -- to fail. This option is primarily useful for SV-COMP. + deriving Eq + +-- | This datatype encodes a variety of tweakable settings that to LLVM +-- overrides. +newtype IntrinsicsOptions + = IntrinsicsOptions + { abnormalExitBehavior :: AbnormalExitBehavior + -- ^ Should Crucible fail when simulating a function which triggers an + -- abnormal exit, such as @abort()@? + } + +-- | The default translation options: +-- +-- * Functions which trigger an abnormal exit will always cause Crucible +-- to fail. +defaultIntrinsicsOptions :: IntrinsicsOptions +defaultIntrinsicsOptions = + IntrinsicsOptions + { abnormalExitBehavior = AlwaysFail + } diff --git a/src/Lang/Crucible/LLVM/MalformedLLVMModule.hs b/src/Lang/Crucible/LLVM/MalformedLLVMModule.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MalformedLLVMModule.hs @@ -0,0 +1,31 @@ +module Lang.Crucible.LLVM.MalformedLLVMModule where + +import qualified Control.Exception as X +import Data.Void + +import Prettyprinter + +------------------------------------------------------------------------ +-- MalformedLLVMModule + +-- | This datatype represents an exception that occurs when an LLVM module +-- is broken in some way; for example, if the types of expressions do +-- not match up in some way. The first argument is a short description +-- of the error, and the remaining arguments are any additional details +-- describing the error. +data MalformedLLVMModule + = MalformedLLVMModule (Doc Void) [Doc Void] + +instance X.Exception MalformedLLVMModule + +instance Show MalformedLLVMModule where + show = show . renderMalformedLLVMModule + +-- Throw a @MalformedLLVMModule@ exception +malformedLLVMModule :: Doc Void -> [Doc Void] -> a +malformedLLVMModule short details = X.throw (MalformedLLVMModule short details) + +-- Render a @MalformedLLVMModule@ exception as a pretty printer document +renderMalformedLLVMModule :: MalformedLLVMModule -> Doc Void +renderMalformedLLVMModule (MalformedLLVMModule short details) = + vcat [short, indent 2 (vcat details)] diff --git a/src/Lang/Crucible/LLVM/MemModel.hs b/src/Lang/Crucible/LLVM/MemModel.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel.hs @@ -0,0 +1,1896 @@ +-------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.MemModel +-- Description : Core definitions of the symbolic C memory model +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Lang.Crucible.LLVM.MemModel + ( -- * Memories + Mem + , memRepr + , mkMemVar + , MemImpl(..) + , SomePointer(..) + , GlobalMap + , emptyMem + , memEndian + , memAllocCount + , memWriteCount + , G.ppMem + , doDumpMem + , BlockSource(..) + , nextBlock + , MemOptions(..) + , IndeterminateLoadBehavior(..) + , defaultMemOptions + , laxPointerMemOptions + + -- * Pointers + , LLVMPointerType + , pattern LLVMPointerRepr + , pattern PtrRepr + , pattern SizeT + , LLVMPtr + , pattern LLVMPointer + , llvmPointerView + , ptrWidth + , G.ppPtr + , G.ppTermExpr + , llvmPointer_bv + , Partial.projectLLVM_bv + + -- * Memory operations + , doMalloc + , doMallocUnbounded + , G.AllocType(..) + , G.Mutability(..) + , doMallocHandle + , ME.FuncLookupError(..) + , ME.ppFuncLookupError + , doLookupHandle + , doInstallHandle + , doMemcpy + , doMemset + , doInvalidate + , doCalloc + , doFree + , doAlloca + , doLoad + , doStore + , doArrayStore + , doArrayStoreUnbounded + , doArrayConstStore + , doArrayConstStoreUnbounded + , loadString + , loadMaybeString + , strLen + , uncheckedMemcpy + , bindLLVMFunPtr + + -- * \"Raw\" operations with LLVMVal + , LLVMVal(..) + , ppLLVMValWithGlobals + , FloatSize(..) + , unpackMemValue + , packMemValue + , loadRaw + , storeRaw + , condStoreRaw + , storeConstRaw + , mallocRaw + , mallocConstRaw + , constToLLVMVal + , constToLLVMValP + , ptrMessage + , Partial.PartLLVMVal(..) + , Partial.assertSafe + , explodeStringValue + + -- Re-exports from MemModel.Value + , isZero + , testEqual + , llvmValStorableType + + -- * Storage types + , StorageType + , storageTypeF + , StorageTypeF(..) + , Field + , storageTypeSize + , fieldVal + , fieldPad + , fieldOffset + , bitvectorType + , arrayType + , mkStructType + , floatType + , doubleType + , x86_fp80Type + , toStorableType + + -- * Pointer operations + , ptrToPtrVal + , mkNullPointer + , ptrIsNull + , ptrEq + , ptrAdd + , ptrSub + , ptrDiff + , doPtrAddOffset + , doPtrSubtract + , isValidPointer + , isAllocatedAlignedPointer + , muxLLVMPtr + , G.isAligned + + -- * Disjointness + , assertDisjointRegions + , buildDisjointRegionsAssertion + , buildDisjointRegionsAssertionWithSub + + -- * Globals + , GlobalSymbol(..) + , doResolveGlobal + , registerGlobal + , allocGlobals + , allocGlobal + , isGlobalPointer + + -- * Misc + , llvmStatementExec + , G.pushStackFrameMem + , G.popStackFrameMem + , G.asMemAllocationArrayStore + , SomeFnHandle(..) + , G.SomeAlloc(..) + , G.possibleAllocs + , G.ppSomeAlloc + , doConditionalWriteOperation + , mergeWriteOperations + , Partial.HasLLVMAnn + , Partial.LLVMAnnMap + , Partial.CexExplanation(..) + , Partial.explainCex + + -- * PtrWidth (re-exports) + , HasPtrWidth + , pattern PtrWidth + , withPtrWidth + + -- * Concretization + , ML.concPtr + , ML.concLLVMVal + , ML.concMem + , concMemImpl + ) where + +import Prelude hiding (seq) + +import Control.Lens hiding (Empty, (:>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State +import Data.Dynamic +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Text (Text) +import Data.Word +import qualified GHC.Stack as GHC +import Numeric.Natural (Natural) +import System.IO (Handle, hPutStrLn) + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import qualified Data.Vector as V +import qualified Text.LLVM.AST as L + +import What4.Interface +import What4.Expr( GroundValue ) +import What4.InterpretedFloatingPoint +import What4.ProgramLoc + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common +import Lang.Crucible.FunctionHandle +import Lang.Crucible.Types +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.GlobalState +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError + +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.Errors.MemoryError + (MemErrContext, MemoryErrorReason(..), MemoryOp(..), ppMemoryErrorReason) +import qualified Lang.Crucible.LLVM.Errors.MemoryError as ME +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack) +import qualified Lang.Crucible.LLVM.MemModel.MemLog as ML +import Lang.Crucible.LLVM.MemModel.Type +import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial +import qualified Lang.Crucible.LLVM.MemModel.Generic as G +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemModel.Options +import Lang.Crucible.LLVM.MemModel.Value +import Lang.Crucible.LLVM.Translation.Constant +import Lang.Crucible.LLVM.Types +import Lang.Crucible.LLVM.Utils +import Lang.Crucible.Panic (panic) + + +import GHC.Stack (HasCallStack) + +---------------------------------------------------------------------- +-- The MemImpl type + +newtype BlockSource = BlockSource (IORef Natural) +type GlobalMap sym = Map L.Symbol (SomePointer sym) + +nextBlock :: BlockSource -> IO Natural +nextBlock (BlockSource ref) = + atomicModifyIORef' ref (\n -> (n+1, n)) + +-- | The implementation of an LLVM memory, containing an +-- allocation-block source, global map, handle map, and heap. +data MemImpl sym = + MemImpl + { memImplBlockSource :: BlockSource + , memImplGlobalMap :: GlobalMap sym + , memImplSymbolMap :: Map Natural L.Symbol -- inverse mapping to 'memImplGlobalMap' + , memImplHandleMap :: Map Natural Dynamic + , memImplHeap :: G.Mem sym + } + +memEndian :: MemImpl sym -> EndianForm +memEndian = G.memEndian . memImplHeap + +memAllocCount :: MemImpl sym -> Int +memAllocCount = G.memAllocCount . memImplHeap + +memWriteCount :: MemImpl sym -> Int +memWriteCount = G.memWriteCount . memImplHeap + +-- | Produce a fresh empty memory. +-- NB, we start counting allocation blocks at '1'. +-- Block number 0 is reserved for representing raw bitvectors. +emptyMem :: EndianForm -> IO (MemImpl sym) +emptyMem endianness = do + blkRef <- newIORef 1 + return $ MemImpl (BlockSource blkRef) Map.empty Map.empty Map.empty (G.emptyMem endianness) + +-- | Pretty print a memory state to the given handle. +doDumpMem :: IsExprBuilder sym => Handle -> MemImpl sym -> IO () +doDumpMem h mem = do + hPutStrLn h (show (G.ppMem (memImplHeap mem))) + +---------------------------------------------------------------------- +-- Memory operations +-- + + +-- | Assert that some undefined behavior doesn't occur when performing memory +-- model operations +assertUndefined :: + (IsSymBackend sym bak, Partial.HasLLVMAnn sym) => + bak -> + CallStack -> + Pred sym -> + (UB.UndefinedBehavior (RegValue' sym)) {- ^ The undesirable behavior -} -> + IO () +assertUndefined bak callStack p ub = + do let sym = backendGetSym bak + p' <- Partial.annotateUB sym callStack ub p + assert bak p' $ AssertFailureSimError "Undefined behavior encountered" (show (UB.explain ub)) + + +assertStoreError :: + (IsSymBackend sym bak, Partial.HasLLVMAnn sym, 1 <= wptr) => + bak -> + MemErrContext sym wptr -> + MemoryErrorReason -> + Pred sym -> + IO () +assertStoreError bak errCtx rsn p = + do let sym = backendGetSym bak + p' <- Partial.annotateME sym errCtx rsn p + assert bak p' $ AssertFailureSimError "Memory store failed" (show (ppMemoryErrorReason rsn)) + +instance IsSymInterface sym => IntrinsicClass sym "LLVM_memory" where + type Intrinsic sym "LLVM_memory" ctx = MemImpl sym + + -- NB: Here we are assuming the global maps of both memories are identical. + -- This should be the case as memories are only supposed to allocate globals at + -- startup, not during program execution. We could check that the maps match, + -- but that would be expensive... + muxIntrinsic _sym _iTypes _nm _ p mem1 mem2 = + do let MemImpl blockSource gMap1 sMap1 hMap1 m1 = mem1 + let MemImpl _blockSource _gMap2 _sMap2 hMap2 m2 = mem2 + --putStrLn "MEM MERGE" + return $ MemImpl blockSource gMap1 sMap1 + (Map.union hMap1 hMap2) + (G.mergeMem p m1 m2) + + pushBranchIntrinsic _sym _iTypes _nm _ctx mem = + do let MemImpl nxt gMap sMap hMap m = mem + --putStrLn "MEM PUSH BRANCH" + return $ MemImpl nxt gMap sMap hMap $ G.branchMem m + + abortBranchIntrinsic _sym _iTypes _nm _ctx mem = + do let MemImpl nxt gMap sMap hMap m = mem + --putStrLn "MEM ABORT BRANCH" + return $ MemImpl nxt gMap sMap hMap $ G.branchAbortMem m + +-- | Top-level evaluation function for LLVM extension statements. +-- LLVM extension statements are used to implement the memory model operations. +llvmStatementExec :: + (Partial.HasLLVMAnn sym, ?memOpts :: MemOptions) => + EvalStmtFunc p sym LLVM +llvmStatementExec stmt cst = + let simCtx = cst^.stateContext + in withBackend simCtx $ \bak -> + runStateT (evalStmt bak stmt) cst + +type EvalM p sym ext rtp blocks ret args a = + StateT (CrucibleState p sym ext rtp blocks ret args) IO a + +-- | Actual workhorse function for evaluating LLVM extension statements. +-- The semantics are explicitly organized as a state transformer monad +-- that modifies the global state of the simulator; this captures the +-- memory accessing effects of these statements. +evalStmt :: forall p sym bak ext rtp blocks ret args tp. + (IsSymBackend sym bak, Partial.HasLLVMAnn sym, GHC.HasCallStack, ?memOpts :: MemOptions) => + bak -> + LLVMStmt (RegEntry sym) tp -> + EvalM p sym ext rtp blocks ret args (RegValue sym tp) +evalStmt bak = eval + where + sym = backendGetSym bak + + getMem :: GlobalVar Mem -> + EvalM p sym ext rtp blocks ret args (MemImpl sym) + getMem mvar = + do gs <- use (stateTree.actFrame.gpGlobals) + case lookupGlobal mvar gs of + Just mem -> return mem + Nothing -> + panic "MemModel.evalStmt.getMem" + [ "Global heap value not initialized." + , "*** Global heap variable: " ++ show mvar + ] + + setMem :: GlobalVar Mem -> + MemImpl sym -> + EvalM p sym ext rtp blocks ret args () + setMem mvar mem = stateTree.actFrame.gpGlobals %= insertGlobal mvar mem + + failedAssert :: String -> String -> EvalM p sym ext rtp blocks ret args a + failedAssert msg details = + lift $ addFailedAssertion bak $ AssertFailureSimError msg details + + eval :: LLVMStmt (RegEntry sym) tp -> + EvalM p sym ext rtp blocks ret args (RegValue sym tp) + eval (LLVM_PushFrame nm mvar) = + do mem <- getMem mvar + let heap' = G.pushStackFrameMem nm (memImplHeap mem) + setMem mvar mem{ memImplHeap = heap' } + + eval (LLVM_PopFrame mvar) = + do mem <- getMem mvar + let heap' = G.popStackFrameMem (memImplHeap mem) + setMem mvar mem{ memImplHeap = heap' } + + eval (LLVM_Alloca _w mvar (regValue -> sz) alignment loc) = + do mem <- getMem mvar + (ptr, mem') <- liftIO $ doAlloca bak mem sz alignment loc + setMem mvar mem' + return ptr + + eval (LLVM_Load mvar (regValue -> ptr) tpr valType alignment) = + do mem <- getMem mvar + liftIO $ doLoad bak mem ptr valType tpr alignment + + eval (LLVM_MemClear mvar (regValue -> ptr) bytes) = + do mem <- getMem mvar + z <- liftIO $ bvLit sym knownNat (BV.zero knownNat) + len <- liftIO $ bvLit sym PtrWidth (bytesToBV PtrWidth bytes) + mem' <- liftIO $ doMemset bak PtrWidth mem ptr z len + setMem mvar mem' + + eval (LLVM_Store mvar (regValue -> ptr) tpr valType alignment (regValue -> val)) = + do mem <- getMem mvar + mem' <- liftIO $ doStore bak mem ptr tpr valType alignment val + setMem mvar mem' + + eval (LLVM_LoadHandle mvar ltp (regValue -> ptr) args ret) = + do mem <- getMem mvar + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + mhandle <- liftIO $ doLookupHandle sym mem ptr + let mop = MemLoadHandleOp ltp gsym ptr (memImplHeap mem) + let expectedTp = FunctionHandleRepr args ret + case mhandle of + Left lookupErr -> lift $ + do p <- Partial.annotateME sym mop (BadFunctionPointer lookupErr) (falsePred sym) + loc <- getCurrentProgramLoc sym + let err = SimError loc (AssertFailureSimError "Failed to load function handle" (show (ME.ppFuncLookupError lookupErr))) + addProofObligation bak (LabeledPred p err) + abortExecBecause (AssertionFailure err) + + Right (VarargsFnHandle h) -> + let err = failedAssert "Failed to load function handle" + (unlines + ["Expected function handle of type " <> show expectedTp + ,"for call to function " <> show (handleName h) + ,"but found varargs handle of non-matching type " ++ show (handleType h) + ]) in + case handleArgTypes h of + prefix Ctx.:> VectorRepr AnyRepr + | Just Refl <- testEquality ret (handleReturnType h) + -> Ctx.dropPrefix args prefix err (return . VarargsFnVal h) + + _ -> err + + Right (SomeFnHandle h) + | Just Refl <- testEquality (handleType h) expectedTp -> return (HandleFnVal h) + | otherwise -> failedAssert + "Failed to load function handle" + (unlines ["Expected function handle of type " <> show expectedTp + , "for call to function " <> show (handleName h) + , "but found calling handle of type " ++ show (handleType h)]) + + eval (LLVM_ResolveGlobal _w mvar (GlobalSymbol symbol)) = + do mem <- getMem mvar + liftIO $ doResolveGlobal bak mem symbol + + eval (LLVM_PtrEq mvar (regValue -> x) (regValue -> y)) = do + mem <- getMem mvar + liftIO $ do + v1 <- isValidPointer sym x mem + v2 <- isValidPointer sym y mem + v3 <- G.notAliasable sym x y (memImplHeap mem) + + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack v1 $ + UB.CompareInvalidPointer UB.Eq (RV x) (RV y) + assertUndefined bak callStack v2 $ + UB.CompareInvalidPointer UB.Eq (RV x) (RV y) + + unless (laxConstantEquality ?memOpts) $ + do let allocs_doc = G.ppAllocs (G.memAllocs (memImplHeap mem)) + let x_doc = G.ppPtr x + let y_doc = G.ppPtr y + -- TODO: Is this undefined behavior? If so, add to the UB module + assert bak v3 $ + AssertFailureSimError + "Const pointers compared for equality" + (unlines [ show x_doc + , show y_doc + , show allocs_doc + ]) + ptrEq sym PtrWidth x y + + eval (LLVM_PtrLe mvar (regValue -> x) (regValue -> y)) = do + mem <- getMem mvar + liftIO $ do + v1 <- isValidPointer sym x mem + v2 <- isValidPointer sym y mem + + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack v1 + (UB.CompareInvalidPointer UB.Leq (RV x) (RV y)) + assertUndefined bak callStack v2 + (UB.CompareInvalidPointer UB.Leq (RV x) (RV y)) + + (le, valid) <- ptrLe sym PtrWidth x y + assertUndefined bak callStack valid + (UB.CompareDifferentAllocs (RV x) (RV y)) + + pure le + + eval (LLVM_PtrAddOffset _w mvar (regValue -> x) (regValue -> y)) = + do mem <- getMem mvar + liftIO $ doPtrAddOffset bak mem x y + + eval (LLVM_PtrSubtract _w mvar (regValue -> x) (regValue -> y)) = + do mem <- getMem mvar + liftIO $ doPtrSubtract bak mem x y + + eval LLVM_Debug{} = pure () + + +mkMemVar :: Text + -> HandleAllocator + -> IO (GlobalVar Mem) +mkMemVar memName halloc = freshGlobalVar halloc memName knownRepr + + +-- | For now, the core message should be on the first line, with details +-- on further lines. Later we should make it more structured. +ptrMessage :: + (IsSymInterface sym) => + String -> + LLVMPtr sym wptr {- ^ pointer involved in message -} -> + StorageType {- ^ type of value pointed to -} -> + String +ptrMessage msg ptr ty = + unlines [ msg + , " address " ++ show (G.ppPtr ptr) + , " at type " ++ show (G.ppType ty) + ] + +-- | Allocate memory on the stack frame of the currently executing function. +doAlloca :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + SymBV sym wptr {- ^ allocation size -} -> + Alignment {- ^ pointer alignment -} -> + String {- ^ source location for use in error messages -} -> + IO (LLVMPtr sym wptr, MemImpl sym) +doAlloca bak mem sz alignment loc = do + let sym = backendGetSym bak + blkNum <- liftIO $ nextBlock (memImplBlockSource mem) + blk <- liftIO $ natLit sym blkNum + z <- liftIO $ bvLit sym PtrWidth (BV.zero PtrWidth) + + let heap' = G.allocMem G.StackAlloc blkNum (Just sz) alignment G.Mutable loc (memImplHeap mem) + let ptr = LLVMPointer blk z + let mem' = mem{ memImplHeap = heap' } + mem'' <- if laxLoadsAndStores ?memOpts + && indeterminateLoadBehavior ?memOpts == StableSymbolic + then doConstStoreStableSymbolic bak mem' ptr (Just sz) alignment + else pure mem' + pure (ptr, mem'') + +-- | Load a 'RegValue' from memory. Both the 'StorageType' and 'TypeRepr' +-- arguments should be computed from a single 'MemType' using +-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr' +-- respectively. +-- +-- Precondition: the pointer is valid and aligned, and the loaded value is defined. +doLoad :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ pointer to load from -} -> + StorageType {- ^ type of value to load -} -> + TypeRepr tp {- ^ crucible type of the result -} -> + Alignment {- ^ assumed pointer alignment -} -> + IO (RegValue sym tp) +doLoad bak mem ptr valType tpr alignment = do + let sym = backendGetSym bak + unpackMemValue sym tpr =<< + Partial.assertSafe bak =<< + loadRaw sym mem ptr valType alignment + +-- | Store a 'RegValue' in memory. Both the 'StorageType' and 'TypeRepr' +-- arguments should be computed from a single 'MemType' using +-- 'toStorableType' and 'Lang.Crucible.LLVM.Translation.Types.llvmTypeAsRepr' +-- respectively. +-- +-- Precondition: the pointer is valid and points to a mutable memory region. +doStore :: + ( IsSymBackend sym bak + , HasPtrWidth wptr + , Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ pointer to store into -} -> + TypeRepr tp -> + StorageType {- ^ type of value to store -} -> + Alignment -> + RegValue sym tp {- ^ value to store -} -> + IO (MemImpl sym) +doStore bak mem ptr tpr valType alignment val = do + --putStrLn "MEM STORE" + let sym = backendGetSym bak + val' <- packMemValue sym valType tpr val + storeRaw bak mem ptr valType alignment val' + +data SomeFnHandle where + SomeFnHandle :: FnHandle args ret -> SomeFnHandle + VarargsFnHandle :: FnHandle (args ::> VectorType AnyType) ret -> SomeFnHandle + +sextendBVTo :: (1 <= w, 1 <= w', IsSymInterface sym) + => sym + -> NatRepr w + -> NatRepr w' + -> SymExpr sym (BaseBVType w) + -> IO (SymExpr sym (BaseBVType w')) +sextendBVTo sym w w' x + | Just Refl <- testEquality w w' = return x + | Just LeqProof <- testLeq (incNat w) w' = bvSext sym w' x + | Just LeqProof <- testLeq (incNat w') w = bvTrunc sym w' x + | otherwise = panic "sextendBVTo" + [ "Impossible widths!" + , show w + , show w' + ] + +-- | Allocate and zero a memory region with /size * number/ bytes. +-- +-- Precondition: the multiplication /size * number/ does not overflow. +doCalloc :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + SymBV sym wptr {- ^ size -} -> + SymBV sym wptr {- ^ number -} -> + Alignment {- ^ Minimum alignment of the resulting allocation -} -> + IO (LLVMPtr sym wptr, MemImpl sym) +doCalloc bak mem sz num alignment = do + let sym = backendGetSym bak + (ov, sz') <- unsignedWideMultiplyBV sym sz num + ov_iszero <- notPred sym =<< bvIsNonzero sym ov + -- TODO, this probably shouldn't be UB + assert bak ov_iszero + (AssertFailureSimError "Multiplication overflow in calloc()" "") + + loc <- plSourceLoc <$> getCurrentProgramLoc sym + let displayString = " " ++ show loc + z <- bvLit sym knownNat (BV.zero knownNat) + (ptr, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz' alignment + mem'' <- doMemset bak PtrWidth mem' ptr z sz' + return (ptr, mem'') + +-- | Allocate a memory region. +doMalloc + :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> G.AllocType {- ^ stack, heap, or global -} + -> G.Mutability {- ^ whether region is read-only -} + -> String {- ^ source location for use in error messages -} + -> MemImpl sym + -> SymBV sym wptr {- ^ allocation size -} + -> Alignment + -> IO (LLVMPtr sym wptr, MemImpl sym) +doMalloc bak allocType mut loc mem sz alignment = doMallocSize (Just sz) bak allocType mut loc mem alignment + +-- | Allocate a memory region of unbounded size. +doMallocUnbounded + :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> G.AllocType {- ^ stack, heap, or global -} + -> G.Mutability {- ^ whether region is read-only -} + -> String {- ^ source location for use in error messages -} + -> MemImpl sym + -> Alignment + -> IO (LLVMPtr sym wptr, MemImpl sym) +doMallocUnbounded = doMallocSize Nothing + +doMallocSize + :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => Maybe (SymBV sym wptr) {- ^ allocation size -} + -> bak + -> G.AllocType {- ^ stack, heap, or global -} + -> G.Mutability {- ^ whether region is read-only -} + -> String {- ^ source location for use in error messages -} + -> MemImpl sym + -> Alignment + -> IO (LLVMPtr sym wptr, MemImpl sym) +doMallocSize sz bak allocType mut loc mem alignment = do + let sym = backendGetSym bak + blkNum <- nextBlock (memImplBlockSource mem) + blk <- natLit sym blkNum + z <- bvLit sym PtrWidth (BV.zero PtrWidth) + let heap' = G.allocMem allocType blkNum sz alignment mut loc (memImplHeap mem) + let ptr = LLVMPointer blk z + let mem' = mem{ memImplHeap = heap' } + mem'' <- if laxLoadsAndStores ?memOpts + && allocType == G.HeapAlloc + && indeterminateLoadBehavior ?memOpts == StableSymbolic + then doConstStoreStableSymbolic bak mem' ptr sz alignment + else pure mem' + return (ptr, mem'') + + + +bindLLVMFunPtr :: + (IsSymBackend sym bak, HasPtrWidth wptr) => + bak -> + L.Symbol -> + FnHandle args ret -> + MemImpl sym -> + IO (MemImpl sym) +bindLLVMFunPtr bak nm h mem + | (_ Ctx.:> VectorRepr AnyRepr) <- handleArgTypes h + + = do ptr <- doResolveGlobal bak mem nm + doInstallHandle bak ptr (VarargsFnHandle h) mem + + | otherwise + = do ptr <- doResolveGlobal bak mem nm + doInstallHandle bak ptr (SomeFnHandle h) mem + +doInstallHandle + :: (Typeable a, IsSymBackend sym bak) + => bak + -> LLVMPtr sym wptr + -> a {- ^ handle -} + -> MemImpl sym + -> IO (MemImpl sym) +doInstallHandle _bak ptr x mem = + case asNat (llvmPointerBlock ptr) of + Just blkNum -> + do let hMap' = Map.insert blkNum (toDyn x) (memImplHandleMap mem) + return mem{ memImplHandleMap = hMap' } + Nothing -> + panic "MemModel.doInstallHandle" + [ "Attempted to install handle for symbolic pointer" + , " " ++ show (ppPtr ptr) + ] + +-- | Allocate a memory region for the given handle. +doMallocHandle + :: (Typeable a, IsSymInterface sym, HasPtrWidth wptr) + => sym + -> G.AllocType {- ^ stack, heap, or global -} + -> String {- ^ source location for use in error messages -} + -> MemImpl sym + -> a {- ^ handle -} + -> IO (LLVMPtr sym wptr, MemImpl sym) +doMallocHandle sym allocType loc mem x = do + blkNum <- nextBlock (memImplBlockSource mem) + blk <- natLit sym blkNum + z <- bvLit sym PtrWidth (BV.zero PtrWidth) + + let heap' = G.allocMem allocType blkNum (Just z) noAlignment G.Immutable loc (memImplHeap mem) + let hMap' = Map.insert blkNum (toDyn x) (memImplHandleMap mem) + let ptr = LLVMPointer blk z + return (ptr, mem{ memImplHeap = heap', memImplHandleMap = hMap' }) + +-- | Look up the handle associated with the given pointer, if any. +doLookupHandle + :: (Typeable a, IsSymInterface sym) + => sym + -> MemImpl sym + -> LLVMPtr sym wptr + -> IO (Either ME.FuncLookupError a) +doLookupHandle _sym mem ptr = do + let LLVMPointer blk _ = ptr + case asNat blk of + Nothing -> return (Left ME.SymbolicPointer) + Just i + | i == 0 -> return (Left ME.RawBitvector) + | otherwise -> + case Map.lookup i (memImplHandleMap mem) of + Nothing -> return (Left ME.NoOverride) + Just x -> + case fromDynamic x of + Nothing -> return (Left (ME.Uncallable (dynTypeRep x))) + Just a -> return (Right a) + +-- | Free the memory region pointed to by the given pointer. +-- +-- Precondition: the pointer either points to the beginning of an allocated +-- region, or is null. Freeing a null pointer has no effect. +doFree + :: (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) + => bak + -> MemImpl sym + -> LLVMPtr sym wptr + -> IO (MemImpl sym) +doFree bak mem ptr = do + let sym = backendGetSym bak + let LLVMPointer blk _off = ptr + loc <- show . plSourceLoc <$> getCurrentProgramLoc sym + (heap', p1, p2, notFreed) <- G.freeMem sym PtrWidth ptr (memImplHeap mem) loc + + -- If this pointer is a handle pointer, remove the associated data + let hMap' = + case asNat blk of + Just i -> Map.delete i (memImplHandleMap mem) + Nothing -> memImplHandleMap mem + + -- NB: free is defined and has no effect if passed a null pointer + isNull <- ptrIsNull sym PtrWidth ptr + p1' <- orPred sym p1 isNull + p2' <- orPred sym p2 isNull + notFreed' <- orPred sym notFreed isNull + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p1' (UB.FreeBadOffset (RV ptr)) + assertUndefined bak callStack p2' (UB.FreeUnallocated (RV ptr)) + assertUndefined bak callStack notFreed' (UB.DoubleFree (RV ptr)) + + return mem{ memImplHeap = heap', memImplHandleMap = hMap' } + +-- | Fill a memory range with copies of the specified byte. +-- +-- Precondition: the memory range falls within a valid allocated region. +doMemset :: + (1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) => + bak -> + NatRepr w -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ destination -} -> + SymBV sym 8 {- ^ fill byte -} -> + SymBV sym w {- ^ length -} -> + IO (MemImpl sym) +doMemset bak w mem dest val len = do + let sym = backendGetSym bak + len' <- sextendBVTo sym w PtrWidth len + + (heap', p) <- G.setMem sym PtrWidth dest val len' (memImplHeap mem) + + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p $ + UB.MemsetInvalidRegion (RV dest) (RV val) (RV len) + + return mem{ memImplHeap = heap' } + +doInvalidate :: + ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + NatRepr w -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ destination -} -> + Text {- ^ message -} -> + SymBV sym w {- ^ length -} -> + IO (MemImpl sym) +doInvalidate bak w mem dest msg len = do + let sym = backendGetSym bak + len' <- sextendBVTo sym w PtrWidth len + + (heap', p) <- if laxLoadsAndStores ?memOpts && + indeterminateLoadBehavior ?memOpts == StableSymbolic + then do p <- G.isAllocatedMutable sym PtrWidth noAlignment dest (Just len') (memImplHeap mem) + mem' <- doStoreStableSymbolic bak mem dest (Just len') noAlignment + pure (memImplHeap mem', p) + else G.invalidateMem sym PtrWidth dest msg len' (memImplHeap mem) + + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) dest + let mop = MemInvalidateOp msg gsym dest len (memImplHeap mem) + p' <- Partial.annotateME sym mop UnwritableRegion p + assert bak p' $ AssertFailureSimError "Invalidation of unallocated or readonly region" "" + + return mem{ memImplHeap = heap' } + +-- | Store an array in memory. +-- +-- Precondition: the pointer is valid and points to a mutable memory region. +doArrayStore + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> SymBV sym w {- ^ array length -} + -> IO (MemImpl sym) +doArrayStore bak mem ptr alignment arr len = doArrayStoreSize (Just len) bak mem ptr alignment arr + +-- | Store an array of unbounded length in memory. +-- +-- Precondition: the pointer is valid and points to a mutable memory region. +doArrayStoreUnbounded + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> IO (MemImpl sym) +doArrayStoreUnbounded = doArrayStoreSize Nothing + + +doArrayStoreSize + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -} + -> bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> IO (MemImpl sym) +doArrayStoreSize len bak mem ptr alignment arr = do + let sym = backendGetSym bak + (heap', p1, p2) <- + G.writeArrayMem sym PtrWidth ptr alignment arr len (memImplHeap mem) + + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + let mop = MemStoreBytesOp gsym ptr len (memImplHeap mem) + + assertStoreError bak mop UnwritableRegion p1 + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment) + + return mem { memImplHeap = heap' } + +-- | Store an array in memory. +-- +-- Precondition: the pointer is valid and points to a mutable or immutable memory region. +-- Therefore it can be used to initialize read-only memory regions. +doArrayConstStore + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> SymBV sym w {- ^ array length -} + -> IO (MemImpl sym) +doArrayConstStore bak mem ptr alignment arr len = + doArrayConstStoreSize (Just len) bak mem ptr alignment arr + +-- | Store an array of unbounded length in memory. +-- +-- Precondition: the pointer is valid and points to a mutable or immutable memory region. +-- Therefore it can be used to initialize read-only memory regions. +doArrayConstStoreUnbounded + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> IO (MemImpl sym) +doArrayConstStoreUnbounded = doArrayConstStoreSize Nothing + +-- | The workhorse for 'doArrayConstStore' (if the first argument is +-- @'Just' len@) or 'doArrayConstStoreUnbounded' (if the first argument is +-- 'Nothing'). +doArrayConstStoreSize + :: (IsSymBackend sym bak, HasPtrWidth w, Partial.HasLLVMAnn sym) + => Maybe (SymBV sym w) {- ^ possibly-unbounded array length -} + -> bak + -> MemImpl sym + -> LLVMPtr sym w {- ^ destination -} + -> Alignment + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ array value -} + -> IO (MemImpl sym) +doArrayConstStoreSize len bak mem ptr alignment arr = do + let sym = backendGetSym bak + (heap', p1, p2) <- + G.writeArrayConstMem sym PtrWidth ptr alignment arr len (memImplHeap mem) + + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + let mop = MemStoreBytesOp gsym ptr len (memImplHeap mem) + + assertStoreError bak mop UnwritableRegion p1 + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment) + + return mem { memImplHeap = heap' } + +-- | Copy memory from source to destination. +-- +-- Precondition: the source and destination pointers fall within valid allocated +-- regions. +doMemcpy :: + ( 1 <= w, IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + NatRepr w -> + MemImpl sym -> + Bool {- ^ if true, require disjoint memory regions -} -> + LLVMPtr sym wptr {- ^ destination -} -> + LLVMPtr sym wptr {- ^ source -} -> + SymBV sym w {- ^ length -} -> + IO (MemImpl sym) +doMemcpy bak w mem mustBeDisjoint dest src len = do + let sym = backendGetSym bak + len' <- sextendBVTo sym w PtrWidth len + + (heap', p1, p2) <- G.copyMem sym PtrWidth dest src len' (memImplHeap mem) + + let gsym_dest = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) dest + let gsym_src = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) src + + let mop = MemCopyOp (gsym_dest, dest) (gsym_src, src) len (memImplHeap mem) + + p1' <- applyUnless (laxLoadsAndStores ?memOpts) + (Partial.annotateME sym mop UnreadableRegion) p1 + p2' <- Partial.annotateME sym mop UnwritableRegion p2 + + assert bak p1' $ AssertFailureSimError "Mem copy failed" "Invalid copy source" + assert bak p2' $ AssertFailureSimError "Mem copy failed" "Invalid copy destination" + + when mustBeDisjoint (assertDisjointRegions bak mop (bvWidth len) dest len src len) + + return mem{ memImplHeap = heap' } + +unsymbol :: L.Symbol -> String +unsymbol (L.Symbol s) = s + +-- | Copy memory from source to destination. This version does +-- no checks to verify that the source and destination allocations +-- are allocated and appropriately sized. +uncheckedMemcpy :: + (IsSymInterface sym, HasPtrWidth wptr) => + sym -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ destination -} -> + LLVMPtr sym wptr {- ^ source -} -> + SymBV sym wptr {- ^ length -} -> + IO (MemImpl sym) +uncheckedMemcpy sym mem dest src len = do + (heap', _p1, _p2) <- G.copyMem sym PtrWidth dest src len (memImplHeap mem) + return mem{ memImplHeap = heap' } + +doPtrSubtract :: + (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr -> + LLVMPtr sym wptr -> + IO (SymBV sym wptr) +doPtrSubtract bak mem x y = do + let sym = backendGetSym bak + (diff, valid) <- ptrDiff sym PtrWidth x y + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack valid $ + UB.PtrSubDifferentAllocs (RV x) (RV y) + pure diff + +-- | Add an offset to a pointer and asserts that the result is a valid pointer. +doPtrAddOffset :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ base pointer -} -> + SymBV sym wptr {- ^ offset -} -> + IO (LLVMPtr sym wptr) +doPtrAddOffset bak m x@(LLVMPointer blk _) off = do + let sym = backendGetSym bak + isBV <- natEq sym blk =<< natLit sym 0 + x' <- ptrAdd sym PtrWidth x off + v <- case asConstantPred isBV of + Just True -> return isBV + _ -> orPred sym isBV =<< G.isValidPointer sym PtrWidth x' (memImplHeap m) + unless (laxLoadsAndStores ?memOpts) $ + let callStack = getCallStack (m ^. to memImplHeap . ML.memState) + in assertUndefined bak callStack v (UB.PtrAddOffsetOutOfBounds (RV x) (RV off)) + return x' + +-- | Store a fresh symbolic value of the appropriate size in the supplied +-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is +-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'. +doStoreStableSymbolic :: + (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ destination -} -> + Maybe (SymBV sym wptr) {- ^ allocation size -} -> + Alignment {- ^ pointer alignment -} -> + IO (MemImpl sym) +doStoreStableSymbolic bak mem ptr mbSz alignment = do + let sym = backendGetSym bak + bytes <- freshConstant sym emptySymbol + (BaseArrayRepr (Ctx.singleton (BaseBVRepr ?ptrWidth)) + (BaseBVRepr (knownNat @8))) + case mbSz of + Just sz -> doArrayStore bak mem ptr alignment bytes sz + Nothing -> doArrayStoreUnbounded bak mem ptr alignment bytes + +-- | Store a fresh symbolic value of the appropriate size in the supplied +-- pointer. This is used in various spots whenever 'laxLoadsAndStores' is +-- enabled and 'indeterminateLoadBehavior' is set to 'StableSymbolic'. +-- +-- Precondition: the pointer is valid and points to a mutable or immutable +-- memory region. Therefore it can be used to initialize read-only memory +-- regions. +doConstStoreStableSymbolic :: + (IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym) => + bak -> + MemImpl sym -> + LLVMPtr sym wptr {- ^ destination -} -> + Maybe (SymBV sym wptr) {- ^ allocation size -} -> + Alignment {- ^ pointer alignment -} -> + IO (MemImpl sym) +doConstStoreStableSymbolic bak mem ptr mbSz alignment = do + let sym = backendGetSym bak + bytes <- freshConstant sym emptySymbol + (BaseArrayRepr (Ctx.singleton (BaseBVRepr ?ptrWidth)) + (BaseBVRepr (knownNat @8))) + case mbSz of + Just sz -> doArrayConstStore bak mem ptr alignment bytes sz + Nothing -> doArrayConstStoreUnbounded bak mem ptr alignment bytes + +-- | This predicate tests if the pointer is a valid, live pointer +-- into the heap, OR is the distinguished NULL pointer. +isValidPointer :: + (IsSymInterface sym, HasPtrWidth wptr) => + sym -> + LLVMPtr sym wptr -> + MemImpl sym -> + IO (Pred sym) +isValidPointer sym p mem = + do np <- ptrIsNull sym PtrWidth p + case asConstantPred np of + Just True -> return np + Just False -> G.isValidPointer sym PtrWidth p (memImplHeap mem) + _ -> orPred sym np =<< G.isValidPointer sym PtrWidth p (memImplHeap mem) + +-- | Return the condition required to prove that the pointer points to +-- a range of 'size' bytes that falls within an allocated region of +-- the appropriate mutability, and also that the pointer is +-- sufficiently aligned. +isAllocatedAlignedPointer :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + Alignment {- ^ minimum required pointer alignment -} -> + G.Mutability {- ^ 'Mutable' means pointed-to region must be writable -} -> + LLVMPtr sym w {- ^ pointer -} -> + Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space) -} -> + MemImpl sym {- ^ memory -} -> + IO (Pred sym) +isAllocatedAlignedPointer sym w alignment mutability ptr size mem = + G.isAllocatedAlignedPointer sym w alignment mutability ptr size (memImplHeap mem) + +-- | Compute the length of a null-terminated string. +-- +-- The pointer to read from must be concrete and nonnull. The contents +-- of the string may be symbolic; HOWEVER, this function will not terminate +-- until it eventually reaches a concete null-terminator or a load error. +strLen :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym {- ^ memory to read from -} -> + LLVMPtr sym wptr {- ^ pointer to string value -} -> + IO (SymBV sym wptr) +strLen bak mem = go (BV.zero PtrWidth) (truePred sym) + where + sym = backendGetSym bak + + go !n cond p = + loadRaw sym mem p (bitvectorType 1) noAlignment >>= \case + Partial.Err pe -> + do ast <- impliesPred sym cond pe + assert bak ast $ AssertFailureSimError "Error during memory load: strlen" "" + bvLit sym PtrWidth (BV.zero PtrWidth) -- bogus value, but have to return something... + Partial.NoErr loadok llvmval -> + do ast <- impliesPred sym cond loadok + assert bak ast $ AssertFailureSimError "Error during memory load: strlen" "" + v <- unpackMemValue sym (LLVMPointerRepr (knownNat @8)) llvmval + test <- bvIsNonzero sym =<< Partial.projectLLVM_bv bak v + iteM bvIte sym + test + (do cond' <- andPred sym cond test + p' <- doPtrAddOffset bak mem p =<< bvLit sym PtrWidth (BV.one PtrWidth) + case BV.succUnsigned PtrWidth n of + Just n_1 -> go n_1 cond' p' + Nothing -> panic "Lang.Crucible.LLVM.MemModel.strLen" ["string length exceeds pointer width"]) + (bvLit sym PtrWidth n) + + +-- | Load a null-terminated string from the memory. +-- +-- The pointer to read from must be concrete and nonnull. Moreover, +-- we require all the characters in the string to be concrete. +-- Otherwise it is very difficult to tell when the string has +-- terminated. If a maximum number of characters is provided, no more +-- than that number of charcters will be read. In either case, +-- `loadString` will stop reading if it encounters a null-terminator. +loadString :: forall sym bak wptr. + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions, GHC.HasCallStack ) => + bak -> + MemImpl sym {- ^ memory to read from -} -> + LLVMPtr sym wptr {- ^ pointer to string value -} -> + Maybe Int {- ^ maximum characters to read -} -> + IO [Word8] +loadString bak mem = go id + where + sym = backendGetSym bak + + go :: ([Word8] -> [Word8]) -> LLVMPtr sym wptr -> Maybe Int -> IO [Word8] + go f _ (Just 0) = return $ f [] + go f p maxChars = do + v <- doLoad bak mem p (bitvectorType 1) (LLVMPointerRepr (knownNat :: NatRepr 8)) noAlignment + x <- Partial.projectLLVM_bv bak v + case BV.asUnsigned <$> asBV x of + Just 0 -> return $ f [] + Just c -> do + let c' :: Word8 = toEnum $ fromInteger c + p' <- doPtrAddOffset bak mem p =<< bvLit sym PtrWidth (BV.one PtrWidth) + go (f . (c':)) p' (fmap (\n -> n - 1) maxChars) + Nothing -> + addFailedAssertion bak + $ Unsupported GHC.callStack "Symbolic value encountered when loading a string" + +-- | Like 'loadString', except the pointer to load may be null. If +-- the pointer is null, we return Nothing. Otherwise we load +-- the string as with 'loadString' and return it. +loadMaybeString :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions, GHC.HasCallStack ) => + bak -> + MemImpl sym {- ^ memory to read from -} -> + LLVMPtr sym wptr {- ^ pointer to string value -} -> + Maybe Int {- ^ maximum characters to read -} -> + IO (Maybe [Word8]) +loadMaybeString bak mem ptr n = do + let sym = backendGetSym bak + isnull <- ptrIsNull sym PtrWidth ptr + case asConstantPred isnull of + Nothing -> addFailedAssertion bak + $ Unsupported GHC.callStack "Symbolic pointer encountered when loading a string" + Just True -> return Nothing + Just False -> Just <$> loadString bak mem ptr n + + +toStorableType :: (MonadFail m, HasPtrWidth wptr) + => MemType + -> m StorageType +toStorableType mt = + case mt of + IntType n -> return $ bitvectorType (bitsToBytes n) + PtrType _ -> return $ bitvectorType (bitsToBytes (natValue PtrWidth)) + PtrOpaqueType -> return $ bitvectorType (bitsToBytes (natValue PtrWidth)) + FloatType -> return $ floatType + DoubleType -> return $ doubleType + X86_FP80Type -> return $ x86_fp80Type + ArrayType n x -> arrayType (fromIntegral n) <$> toStorableType x + VecType n x -> arrayType (fromIntegral n) <$> toStorableType x + MetadataType -> fail "toStorableType: Cannot store metadata values" + StructType si -> mkStructType <$> traverse transField (siFields si) + where transField :: MonadFail m => FieldInfo -> m (StorageType, Bytes) + transField fi = do + t <- toStorableType $ fiType fi + return (t, fiPadding fi) + +---------------------------------------------------------------------- +-- "Raw" operations +-- + +-- | Load an LLVM value from memory. Asserts that the pointer is valid and the +-- result value is not undefined. +loadRaw :: ( IsSymInterface sym, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => sym + -> MemImpl sym + -> LLVMPtr sym wptr + -> StorageType + -> Alignment + -> IO (Partial.PartLLVMVal sym) +loadRaw sym mem ptr valType alignment = do + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + G.readMem sym PtrWidth gsym ptr valType alignment (memImplHeap mem) + +-- | Store an LLVM value in memory. Asserts that the pointer is valid and points +-- to a mutable memory region. +storeRaw :: + ( IsSymBackend sym bak + , HasPtrWidth wptr + , Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> MemImpl sym + -> LLVMPtr sym wptr {- ^ pointer to store into -} + -> StorageType {- ^ type of value to store -} + -> Alignment + -> LLVMVal sym {- ^ value to store -} + -> IO (MemImpl sym) +storeRaw bak mem ptr valType alignment val = do + let sym = backendGetSym bak + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + (heap', p1, p2) <- G.writeMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem) + + let mop = MemStoreOp valType gsym ptr (memImplHeap mem) + + assertStoreError bak mop UnwritableRegion p1 + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment) + + return mem{ memImplHeap = heap' } + +-- | Perform a memory write operation if the condition is true, +-- do not change the memory otherwise. +-- +-- Asserts that the write operation is valid when cond is true. +doConditionalWriteOperation + :: (IsSymBackend sym bak) + => bak + -> MemImpl sym + -> Pred sym {- ^ write condition -} + -> (MemImpl sym -> IO (MemImpl sym)) {- ^ memory write operation -} + -> IO (MemImpl sym) +doConditionalWriteOperation bak mem cond write_op = + mergeWriteOperations bak mem cond write_op return + +-- | Merge memory write operations on condition: if the condition is true, +-- perform the true branch write operation, otherwise perform the false branch +-- write operation. +-- +-- Asserts that the true branch write operation is valid when cond is true, and +-- that the false branch write operation is valid when cond is not true. +mergeWriteOperations + :: (IsSymBackend sym bak) + => bak + -> MemImpl sym + -> Pred sym {- ^ merge condition -} + -> (MemImpl sym -> IO (MemImpl sym)) {- ^ true branch memory write operation -} + -> (MemImpl sym -> IO (MemImpl sym)) {- ^ false branch memory write operation -} + -> IO (MemImpl sym) +mergeWriteOperations bak mem cond true_write_op false_write_op = do + let sym = backendGetSym bak + let branched_mem = mem { memImplHeap = G.branchMem $ memImplHeap mem } + loc <- getCurrentProgramLoc sym + + true_frame_id <- pushAssumptionFrame bak + addAssumption bak (GenericAssumption loc "conditional memory write predicate" cond) + true_mutated_heap <- memImplHeap <$> true_write_op branched_mem + _ <- popAssumptionFrame bak true_frame_id + + false_frame_id <- pushAssumptionFrame bak + not_cond <- notPred sym cond + addAssumption bak (GenericAssumption loc "conditional memory write predicate" not_cond) + false_mutated_heap <- memImplHeap <$> false_write_op branched_mem + _ <- popAssumptionFrame bak false_frame_id + + return $! + mem { memImplHeap = G.mergeMem cond true_mutated_heap false_mutated_heap } + +-- | Store an LLVM value in memory if the condition is true, and +-- otherwise leaves memory unchanged. +-- +-- Asserts that the pointer is valid and points to a mutable memory +-- region when cond is true. +condStoreRaw :: + ( IsSymBackend sym bak + , HasPtrWidth wptr + , Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions + ) + => bak + -> MemImpl sym + -> Pred sym {- ^ Predicate that determines if we actually write. -} + -> LLVMPtr sym wptr {- ^ pointer to store into -} + -> StorageType {- ^ type of value to store -} + -> Alignment + -> LLVMVal sym {- ^ value to store -} + -> IO (MemImpl sym) +condStoreRaw bak mem cond ptr valType alignment val = do + let sym = backendGetSym bak + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + -- Get current heap + let preBranchHeap = memImplHeap mem + -- Push a branch to the heap + let postBranchHeap = G.branchMem preBranchHeap + + let mop = MemStoreOp valType gsym ptr preBranchHeap + + -- Write to the heap + (postWriteHeap, isAllocated, isAligned) <- G.writeMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem) + -- Assert is allocated if write executes + do condIsAllocated <- impliesPred sym cond isAllocated + assertStoreError bak mop UnwritableRegion condIsAllocated + -- Assert is aligned if write executes + do condIsAligned <- impliesPred sym cond isAligned + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack condIsAligned (UB.WriteBadAlignment (RV ptr) alignment) + -- Merge the write heap and non-write heap + let mergedHeap = G.mergeMem cond postWriteHeap postBranchHeap + -- Return new memory + return $! mem{ memImplHeap = mergedHeap } + +-- | Store an LLVM value in memory. The pointed-to memory region may +-- be either mutable or immutable; thus 'storeConstRaw' can be used to +-- initialize read-only memory regions. +storeConstRaw :: + ( IsSymBackend sym bak + , HasPtrWidth wptr + , Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> MemImpl sym + -> LLVMPtr sym wptr {- ^ pointer to store into -} + -> StorageType {- ^ type of value to store -} + -> Alignment + -> LLVMVal sym {- ^ value to store -} + -> IO (MemImpl sym) +storeConstRaw bak mem ptr valType alignment val = do + let sym = backendGetSym bak + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + (heap', p1, p2) <- G.writeConstMem sym PtrWidth gsym ptr valType alignment val (memImplHeap mem) + + let mop = MemStoreOp valType gsym ptr (memImplHeap mem) + + assertStoreError bak mop UnwritableRegion p1 + let callStack = getCallStack (mem ^. to memImplHeap . ML.memState) + assertUndefined bak callStack p2 (UB.WriteBadAlignment (RV ptr) alignment) + + return mem{ memImplHeap = heap' } + +-- | Allocate a memory region on the heap, with no source location info. +mallocRaw + :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> MemImpl sym + -> SymBV sym wptr {- ^ size in bytes -} + -> Alignment + -> IO (LLVMPtr sym wptr, MemImpl sym) +mallocRaw bak mem sz alignment = + doMalloc bak G.HeapAlloc G.Mutable "" mem sz alignment + +-- | Allocate a read-only memory region on the heap, with no source location info. +mallocConstRaw + :: ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => bak + -> MemImpl sym + -> SymBV sym wptr + -> Alignment + -> IO (LLVMPtr sym wptr, MemImpl sym) +mallocConstRaw bak mem sz alignment = + doMalloc bak G.HeapAlloc G.Immutable "" mem sz alignment + +---------------------------------------------------------------------- +-- Packing and unpacking +-- + +unpackZero :: + (HasCallStack, IsSymInterface sym) => + sym -> + StorageType -> + TypeRepr tp {- ^ Crucible type -} -> + IO (RegValue sym tp) +unpackZero sym tp tpr = + let mismatch = storageTypeMismatch "MemModel.unpackZero" tp tpr in + case storageTypeF tp of + Bitvector bytes -> + zeroInt sym bytes $ \case + Nothing -> fail ("Improper storable type: " ++ show tp) + Just (blk, bv) -> + case tpr of + LLVMPointerRepr w | Just Refl <- testEquality (bvWidth bv) w -> return (LLVMPointer blk bv) + _ -> mismatch + + Float -> + case tpr of + FloatRepr SingleFloatRepr -> iFloatLitRational sym SingleFloatRepr 0 + _ -> mismatch + + Double -> + case tpr of + FloatRepr DoubleFloatRepr -> iFloatLitRational sym DoubleFloatRepr 0 + _ -> mismatch + + X86_FP80 -> + case tpr of + FloatRepr X86_80FloatRepr -> iFloatLitRational sym X86_80FloatRepr 0 + _ -> mismatch + + Array n tp' -> + case tpr of + VectorRepr tpr' -> + do v <- unpackZero sym tp' tpr' + return $ V.replicate (fromIntegral n) v + _ -> mismatch + + Struct flds -> + case tpr of + StructRepr fldCtx | V.length flds == Ctx.sizeInt (Ctx.size fldCtx) -> + Ctx.traverseWithIndex + (\i tpr' -> RV <$> unpackZero sym (flds V.! (Ctx.indexVal i) ^. fieldVal) tpr') + fldCtx + + _ -> mismatch + + +storageTypeMismatch :: + String -> + StorageType -> + TypeRepr tp -> + IO a +storageTypeMismatch nm tp tpr = + panic nm + [ "Storage type mismatch in " ++ nm + , " Storage type: " ++ show tp + , " Crucible type: " ++ show tpr + ] + +-- | Unpack an 'LLVMVal' to produce a 'RegValue'. +unpackMemValue :: + (HasCallStack, IsSymInterface sym) => + sym -> + TypeRepr tp -> + LLVMVal sym -> + IO (RegValue sym tp) + +unpackMemValue sym tpr (LLVMValZero tp) = unpackZero sym tp tpr + +unpackMemValue _sym (LLVMPointerRepr w) (LLVMValInt blk bv) + | Just Refl <- testEquality (bvWidth bv) w + = return $ LLVMPointer blk bv + +unpackMemValue _ (FloatRepr SingleFloatRepr) (LLVMValFloat SingleSize x) = return x +unpackMemValue _ (FloatRepr DoubleFloatRepr) (LLVMValFloat DoubleSize x) = return x +unpackMemValue _ (FloatRepr X86_80FloatRepr) (LLVMValFloat X86_FP80Size x) = return x + +unpackMemValue sym (StructRepr ctx) (LLVMValStruct xs) + | V.length xs == Ctx.sizeInt (Ctx.size ctx) + = Ctx.traverseWithIndex + (\i tpr -> RV <$> unpackMemValue sym tpr (xs V.! Ctx.indexVal i ^. _2)) + ctx + +unpackMemValue sym (VectorRepr tpr) (LLVMValArray _tp xs) + = traverse (unpackMemValue sym tpr) xs + +unpackMemValue _sym ctp@(BVRepr _) lval@(LLVMValInt _ _) = + panic "MemModel.unpackMemValue" + [ "Cannot unpack an integer LLVM value to a crucible bitvector type" + , "*** Crucible type: " ++ show ctp + , "*** LLVM value: " ++ show lval + ] + +unpackMemValue _ tpr v@(LLVMValUndef _) = + panic "MemModel.unpackMemValue" + [ "Cannot unpack an `undef` value" + , "*** Crucible type: " ++ show tpr + , "*** Undef value: " ++ show v + ] + +unpackMemValue _ tpr v = + panic "MemModel.unpackMemValue" + [ "Crucible type mismatch when unpacking LLVM value" + , "*** Crucible type: " ++ show tpr + , "*** LLVM value: " ++ show v + ] + + +-- | Pack a 'RegValue' into an 'LLVMVal'. The LLVM storage type and +-- the Crucible type must be compatible. +packMemValue :: + IsSymInterface sym => + sym -> + StorageType {- ^ LLVM storage type -} -> + TypeRepr tp {- ^ Crucible type -} -> + RegValue sym tp -> + IO (LLVMVal sym) + +packMemValue _ (StorageType Float _) (FloatRepr SingleFloatRepr) x = + return $ LLVMValFloat SingleSize x + +packMemValue _ (StorageType Double _) (FloatRepr DoubleFloatRepr) x = + return $ LLVMValFloat DoubleSize x + +packMemValue _ (StorageType X86_FP80 _) (FloatRepr X86_80FloatRepr) x = + return $ LLVMValFloat X86_FP80Size x + +packMemValue sym (StorageType (Bitvector bytes) _) (BVRepr w) bv + | bitsToBytes (natValue w) == bytes = + do blk0 <- natLit sym 0 + return $ LLVMValInt blk0 bv + +packMemValue _sym (StorageType (Bitvector bytes) _) (LLVMPointerRepr w) (LLVMPointer blk off) + | bitsToBytes (natValue w) == bytes = + return $ LLVMValInt blk off + +packMemValue sym (StorageType (Array sz tp) _) (VectorRepr tpr) vec + | V.length vec == fromIntegral sz = do + vec' <- traverse (packMemValue sym tp tpr) vec + return $ LLVMValArray tp vec' + +packMemValue sym (StorageType (Struct fls) _) (StructRepr ctx) xs = do + fls' <- V.generateM (V.length fls) $ \i -> do + let fl = fls V.! i + case Ctx.intIndex i (Ctx.size ctx) of + Just (Some idx) -> do + let tpr = ctx Ctx.! idx + let RV val = xs Ctx.! idx + val' <- packMemValue sym (fl^.fieldVal) tpr val + return (fl, val') + _ -> panic "MemModel.packMemValue" + [ "Mismatch between LLVM and Crucible types" + , "*** Filed out of bounds: " ++ show i + ] + return $ LLVMValStruct fls' + +packMemValue _ stTy crTy _ = + panic "MemModel.packMemValue" + [ "Type mismatch when storing value." + , "*** Expected storable type: " ++ show stTy + , "*** Given crucible type: " ++ show crTy + ] + + +---------------------------------------------------------------------- +-- Disjointness +-- + +-- | Assert that two memory regions are disjoint. +-- Two memory regions are disjoint if any of the following are true: +-- +-- 1. Their block pointers are different +-- 2. Their blocks are the same, but /dest+dlen/ <= /src/ +-- 3. Their blocks are the same, but /src+slen/ <= /dest/ +assertDisjointRegions :: + (1 <= w, HasPtrWidth wptr, IsSymBackend sym bak, Partial.HasLLVMAnn sym) => + bak -> + MemoryOp sym wptr -> + NatRepr w -> + LLVMPtr sym wptr {- ^ pointer to region 1 -} -> + SymBV sym w {- ^ length of region 1 -} -> + LLVMPtr sym wptr {- ^ pointer to region 2 -} -> + SymBV sym w {- ^ length of region 2 -} -> + IO () +assertDisjointRegions bak mop w dest dlen src slen = do + let sym = backendGetSym bak + c <- buildDisjointRegionsAssertion sym w dest dlen src slen + c' <- Partial.annotateME sym mop OverlappingRegions c + assert bak c' (AssertFailureSimError "Memory regions not disjoint" "") + +buildDisjointRegionsAssertion :: + (1 <= w, HasPtrWidth wptr, IsSymInterface sym) => + sym -> + NatRepr w -> + LLVMPtr sym wptr {- ^ pointer to region 1 -} -> + SymBV sym w {- ^ length of region 1 -} -> + LLVMPtr sym wptr {- ^ pointer to region 2 -} -> + SymBV sym w {- ^ length of region 2 -} -> + IO (Pred sym) +buildDisjointRegionsAssertion sym w dest dlen src slen = do + let LLVMPointer dblk doff = dest + let LLVMPointer sblk soff = src + + dend <- bvAdd sym doff =<< sextendBVTo sym w PtrWidth dlen + send <- bvAdd sym soff =<< sextendBVTo sym w PtrWidth slen + + diffBlk <- notPred sym =<< natEq sym dblk sblk + destfirst <- bvSle sym dend soff + srcfirst <- bvSle sym send doff + + orPred sym diffBlk =<< orPred sym destfirst srcfirst + +-- | Build the condition that two memory regions are disjoint, using +-- subtraction and comparison to zero instead of direct comparison (that is, +-- 0 <= y - x instead of x <= y). This enables semiring and abstract domain +-- simplifications. The result if false if any offset is not positive when +-- interpreted as signed bitvector. +buildDisjointRegionsAssertionWithSub :: + (HasPtrWidth wptr, IsSymInterface sym) => + sym -> + LLVMPtr sym wptr {- ^ pointer to region 1 -} -> + SymBV sym wptr {- ^ length of region 1 -} -> + LLVMPtr sym wptr {- ^ pointer to region 2 -} -> + SymBV sym wptr {- ^ length of region 2 -} -> + IO (Pred sym) +buildDisjointRegionsAssertionWithSub sym dest dlen src slen = do + let LLVMPointer dblk doff = dest + let LLVMPointer sblk soff = src + + dend <- bvAdd sym doff dlen + send <- bvAdd sym soff slen + + zero_bv <- bvLit sym PtrWidth $ BV.zero PtrWidth + + diffBlk <- notPred sym =<< natEq sym dblk sblk + + allPos <- andAllOf sym folded =<< mapM (bvSle sym zero_bv) [doff, dend, soff, send] + destfirst <- bvSle sym zero_bv =<< bvSub sym soff dend + srcfirst <- bvSle sym zero_bv =<< bvSub sym doff send + + orPred sym diffBlk =<< andPred sym allPos =<< orPred sym destfirst srcfirst + +---------------------------------------------------------------------- +-- constToLLVMVal +-- + +-- | This is used (by saw-script) to initialize globals. +-- +-- In this translation, we lose the distinction between pointers and ints. +-- +-- This is parameterized (hence, \"P\") over a function for looking up the +-- pointer values of global symbols. This parameter is used by @populateGlobal@ +-- to recursively populate globals that may reference one another. +constToLLVMValP :: forall wptr sym io. + ( MonadIO io + , MonadFail io + , HasPtrWidth wptr + , IsSymInterface sym + , HasCallStack + ) => sym -- ^ The symbolic backend + -> (L.Symbol -> io (LLVMPtr sym wptr)) -- ^ How to look up global symbols + -> LLVMConst -- ^ Constant expression to translate + -> io (LLVMVal sym) + +-- See comment on @LLVMVal@ on why we use a literal 0. +constToLLVMValP sym _ (IntConst w i) = liftIO $ + LLVMValInt <$> natLit sym 0 <*> bvLit sym w i + +constToLLVMValP sym _ (FloatConst f) = liftIO $ + LLVMValFloat SingleSize <$> iFloatLitSingle sym f + +constToLLVMValP sym _ (DoubleConst d) = liftIO $ + LLVMValFloat DoubleSize <$> iFloatLitDouble sym d + +constToLLVMValP sym _ (LongDoubleConst (L.FP80_LongDouble e s)) = liftIO $ + LLVMValFloat X86_FP80Size <$> iFloatLitLongDouble sym (X86_80Val e s) + +constToLLVMValP _ _ (StringConst bs) = + pure (LLVMValString bs) + +constToLLVMValP sym look (ArrayConst memty xs) = + LLVMValArray <$> liftIO (toStorableType memty) + <*> (V.fromList <$> traverse (constToLLVMValP sym look) xs) + +-- Same as the array case +constToLLVMValP sym look (VectorConst memty xs) = + LLVMValArray <$> liftIO (toStorableType memty) + <*> (V.fromList <$> traverse (constToLLVMValP sym look) xs) + +constToLLVMValP sym look (StructConst sInfo xs) = + LLVMValStruct <$> + V.zipWithM (\x y -> (,) <$> liftIO (fiToFT x) <*> constToLLVMValP sym look y) + (siFields sInfo) + (V.fromList xs) + +-- SymbolConsts are offsets from global pointers. We translate them into the +-- pointer they represent. +constToLLVMValP sym look (SymbolConst symb i) = do + -- Pointer to the global "symb" + ptr <- look symb + -- Offset to be added, as a bitvector + ibv <- liftIO $ bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth i) + + -- blk is the allocation number that this global is stored in. + -- In contrast to the case for @IntConst@ above, it is non-zero. + let (blk, offset) = llvmPointerView ptr + LLVMValInt blk <$> liftIO (bvAdd sym offset ibv) + +constToLLVMValP _sym _look (ZeroConst memty) = liftIO $ + LLVMValZero <$> toStorableType memty +constToLLVMValP _sym _look (UndefConst memty) = liftIO $ + LLVMValUndef <$> toStorableType memty + + +-- | Translate a constant into an LLVM runtime value. Assumes all necessary +-- globals have already been populated into the @'MemImpl'@. +constToLLVMVal :: forall wptr sym bak io. + ( MonadIO io + , MonadFail io + , HasPtrWidth wptr + , IsSymBackend sym bak + , HasCallStack + ) => bak -- ^ The symbolic backend + -> MemImpl sym -- ^ The current memory state, for looking up globals + -> LLVMConst -- ^ Constant expression to translate + -> io (LLVMVal sym) -- ^ Runtime representation of the constant expression + +-- See comment on @LLVMVal@ on why we use a literal 0. +constToLLVMVal bak mem = + constToLLVMValP (backendGetSym bak) + (\symb -> liftIO $ doResolveGlobal bak mem symb) + +-- TODO are these types just identical? Maybe we should combine them. +fiToFT :: (HasPtrWidth wptr, MonadFail m) => FieldInfo -> m (Field StorageType) +fiToFT fi = fmap (\t -> mkField (fiOffset fi) t (fiPadding fi)) + (toStorableType $ fiType fi) + +---------------------------------------------------------------------- +-- Globals +-- + +-- | Look up a 'Symbol' in the global map of the given 'MemImpl'. +-- Panic if the symbol is not present in the global map. +doResolveGlobal :: + (IsSymBackend sym bak, HasPtrWidth wptr, HasCallStack) => + bak -> + MemImpl sym -> + L.Symbol {- ^ name of global -} -> + IO (LLVMPtr sym wptr) +doResolveGlobal bak mem symbol@(L.Symbol name) = + let lookedUp = Map.lookup symbol (memImplGlobalMap mem) + msg1 = "Global allocation has incorrect width" + msg1Details = mconcat [ "Allocation associated with global symbol \"" + , name + , "\" is not a pointer of the correct width" + ] + msg2 = "Global symbol not allocated" + msg2Details = mconcat [ "Global symbol \"" + , name + , "\" has no associated allocation" + ] + in case lookedUp of + Just (SomePointer ptr) | PtrWidth <- ptrWidth ptr -> return ptr + _ -> addFailedAssertion bak $ + if isJust lookedUp + then AssertFailureSimError msg1 msg1Details + else AssertFailureSimError msg2 msg2Details + +-- | Add an entry to the global map of the given 'MemImpl'. +-- +-- This takes a list of symbols because there may be aliases to a global. +registerGlobal :: + (IsExprBuilder sym, 1 <= wptr) => + MemImpl sym -> [L.Symbol] -> LLVMPtr sym wptr -> MemImpl sym +registerGlobal (MemImpl blockSource gMap sMap hMap mem) symbols ptr = + MemImpl blockSource gMap' sMap' hMap mem + where + gMap' = foldr (\s m -> Map.insert s (SomePointer ptr) m) gMap symbols + sMap' = + fromMaybe sMap $ + do symbol <- listToMaybe symbols + n <- asNat (llvmPointerBlock ptr) + z <- asBV (llvmPointerOffset ptr) + guard (BV.asUnsigned z == 0) + Just (Map.insert n symbol sMap) + +-- | Allocate memory for each global, and register all the resulting +-- pointers in the global map. +allocGlobals :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + [(L.Global, [L.Symbol], Bytes, Alignment)] -> + MemImpl sym -> + IO (MemImpl sym) +allocGlobals bak gs mem = foldM (allocGlobal bak) mem gs + +allocGlobal :: + ( IsSymBackend sym bak, HasPtrWidth wptr, Partial.HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + (L.Global, [L.Symbol], Bytes, Alignment) -> + IO (MemImpl sym) +allocGlobal bak mem (g, aliases, sz, alignment) = do + let sym = backendGetSym bak + let symbol@(L.Symbol sym_str) = L.globalSym g + let displayName = "[global variable ] " ++ sym_str + let mut = if L.gaConstant (L.globalAttrs g) then G.Immutable else G.Mutable + sz' <- bvLit sym PtrWidth (bytesToBV PtrWidth sz) + -- TODO: Aliases are not propagated to doMalloc for error messages + (ptr, mem') <- doMalloc bak G.GlobalAlloc mut displayName mem sz' alignment + return (registerGlobal mem' (symbol:aliases) ptr) + + +concSomePointer :: + IsSymInterface sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + SomePointer sym -> IO (SomePointer sym) +concSomePointer sym conc (SomePointer ptr) = + SomePointer <$> ML.concPtr sym conc ptr + +concMemImpl :: + IsSymInterface sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemImpl sym -> IO (MemImpl sym) +concMemImpl sym conc mem = + do heap' <- ML.concMem sym conc (memImplHeap mem) + gm' <- traverse (concSomePointer sym conc) (memImplGlobalMap mem) + pure mem{ memImplHeap = heap', memImplGlobalMap = gm' } diff --git a/src/Lang/Crucible/LLVM/MemModel/CallStack.hs b/src/Lang/Crucible/LLVM/MemModel/CallStack.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/CallStack.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.CallStack +-- Description : Call stacks from the LLVM memory model +-- Copyright : (c) Galois, Inc 2024 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +------------------------------------------------------------------------ + +module Lang.Crucible.LLVM.MemModel.CallStack + ( CallStack + , null + , getCallStack + , ppCallStack + ) where + +import Prelude hiding (null) +import Lang.Crucible.LLVM.MemModel.CallStack.Internal diff --git a/src/Lang/Crucible/LLVM/MemModel/CallStack/Internal.hs b/src/Lang/Crucible/LLVM/MemModel/CallStack/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/CallStack/Internal.hs @@ -0,0 +1,53 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.CallStack.Internal +-- Description : Call stacks from the LLVM memory model (implementation details) +-- Copyright : (c) Galois, Inc 2024 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Lang.Crucible.LLVM.MemModel.CallStack.Internal where + +import Data.Foldable (toList) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Prettyprinter as PP + +import Lang.Crucible.LLVM.MemModel.MemLog (MemState(..)) + +newtype FunctionName = + FunctionName { getFunctionName :: Text } + deriving (Eq, Monoid, Ord, Semigroup) + +-- | Call stacks (lists of function names), mostly for diagnostics +newtype CallStack = + CallStack { runCallStack :: Seq FunctionName } + deriving (Eq, Monoid, Ord, Semigroup) + +-- | Add a function name to the top of the call stack +cons :: FunctionName -> CallStack -> CallStack +cons top (CallStack rest) = CallStack (top Seq.<| rest) + +-- | Is this 'CallStack' empty? +null :: CallStack -> Bool +null = Seq.null . runCallStack + +-- | Summarize the 'StackFrame's of a 'MemState' into a 'CallStack' +getCallStack :: MemState sym -> CallStack +getCallStack = + \case + EmptyMem{} -> CallStack mempty + StackFrame _ _ nm _ rest -> cons (FunctionName nm) (getCallStack rest) + BranchFrame _ _ _ rest -> getCallStack rest + +-- | Pretty-print a call stack (one function per line) +ppCallStack :: CallStack -> PP.Doc ann +ppCallStack = + PP.vsep . toList . fmap (PP.pretty . getFunctionName) . runCallStack diff --git a/src/Lang/Crucible/LLVM/MemModel/Common.hs b/src/Lang/Crucible/LLVM/MemModel/Common.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Common.hs @@ -0,0 +1,713 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Common +-- Description : Core definitions of the symbolic C memory model +-- Copyright : (c) Galois, Inc 2011-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Lang.Crucible.LLVM.MemModel.Common + ( -- * Range declarations. + Range(..) + + -- * Pointer declarations + , OffsetExpr(..) + , IntExpr(..) + , Cond(..) + + , Mux(..) + + , ValueCtor(..) + + , BasePreference(..) + + , RangeLoad(..) + , rangeLoad + , fixedOffsetRangeLoad + , fixedSizeRangeLoad + , symbolicRangeLoad + , symbolicUnboundedRangeLoad + + , ValueView(..) + + , ValueLoad(..) + , valueLoad + , LinearLoadStoreOffsetDiff(..) + , symbolicValueLoad + , loadBitvector + + , memsetValue + , loadTypedValueFromBytes + ) where + +import Control.Exception (assert) +import Control.Lens +import Control.Monad (guard) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural + +import Lang.Crucible.Panic ( panic ) +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.MemModel.Type + +-- | @R i j@ denotes that the write should store in range [i..j). +data Range = R { rStart :: Addr, _rEnd :: Addr } + deriving (Eq, Show) + +-- Value + +data OffsetExpr + = OffsetAdd OffsetExpr IntExpr + | Load + | Store + deriving (Show) + +data IntExpr + = OffsetDiff OffsetExpr OffsetExpr + | IntAdd IntExpr IntExpr + | CValue Bytes + | StoreSize + deriving (Show) + +data Cond + = OffsetEq OffsetExpr OffsetExpr + | OffsetLe OffsetExpr OffsetExpr + | IntEq IntExpr IntExpr + | IntLe IntExpr IntExpr + | And Cond Cond + | Or Cond Cond + deriving (Show) + +(.==) :: OffsetExpr -> OffsetExpr -> Cond +infix 4 .== +x .== y = OffsetEq x y + +(.<=) :: OffsetExpr -> OffsetExpr -> Cond +infix 4 .<= +x .<= y = OffsetLe x y + +infixl 6 .+ +(.+) :: OffsetExpr -> IntExpr -> OffsetExpr +x .+ CValue 0 = x +x .+ y = OffsetAdd x y + +infixl 6 .- +(.-) :: OffsetExpr -> OffsetExpr -> IntExpr +x .- y = OffsetDiff x y + +-- Muxs + +data Mux a + = Mux Cond (Mux a) (Mux a) + | MuxTable OffsetExpr OffsetExpr (Map Bytes (Mux a)) (Mux a) + -- ^ 'MuxTable' encodes a lookup table: @'MuxTable' p1 p2 + -- 'Map.empty' z@ is equivalent to @z@, and @'MuxTable' p1 p2 + -- ('Map.insert' (i, x) m) z@ is equivalent to @'Mux' (p1 '.+' + -- 'CValue' i '.==' p2) x ('MuxTable' p1 p2 m z)@. + | MuxVar a + deriving Show + +-- Variable for mem model. + +loadOffset :: Bytes -> OffsetExpr +loadOffset n = Load .+ CValue n + +storeOffset :: Bytes -> OffsetExpr +storeOffset n = Store .+ CValue n + +storeEnd :: OffsetExpr +storeEnd = Store .+ StoreSize + +-- | @loadInStoreRange n@ returns predicate if Store <= Load && Load <= Store + n +loadInStoreRange :: Bytes -> Cond +loadInStoreRange (Bytes 0) = Load .== Store +loadInStoreRange n = And (Store .<= Load) + (Load .<= Store .+ CValue n) + +-- Value constructor + +-- | Describes how to construct a larger LLVM value as a combination +-- of smaller components. +data ValueCtor a + = ValueCtorVar a + -- | Concatenates two bitvectors. + -- The first bitvector contains values stored at the low-address bytes + -- while the second contains values at the high-address bytes. Thus, the + -- meaning of this depends on the endianness of the target architecture. + | ConcatBV (ValueCtor a) (ValueCtor a) + | BVToFloat (ValueCtor a) + | BVToDouble (ValueCtor a) + | BVToX86_FP80 (ValueCtor a) + -- | Cons one value to beginning of array. + | ConsArray (ValueCtor a) (ValueCtor a) + | AppendArray (ValueCtor a) (ValueCtor a) + | MkArray StorageType (Vector (ValueCtor a)) + | MkStruct (Vector (Field StorageType, ValueCtor a)) + deriving (Functor, Foldable, Traversable, Show) + +concatBV :: Bytes -> ValueCtor a -> Bytes -> ValueCtor a -> ValueCtor a +concatBV _xw x _yw y = ConcatBV x y + +singletonArray :: StorageType -> ValueCtor a -> ValueCtor a +singletonArray tp e = MkArray tp (V.singleton e) + +-- | Create value of type that splits at a particular byte offset. +splitTypeValue :: StorageType -- ^ Type of value to create + -> Offset -- ^ Bytes offset to slice type at. + -> (Offset -> StorageType -> ValueCtor a) -- ^ Function for subtypes. + -> ValueCtor a +splitTypeValue tp d subFn = assert (d > 0) $ + case storageTypeF tp of + Bitvector sz -> assert (d < sz) $ + concatBV d (subFn 0 (bitvectorType d)) + (sz - d) (subFn d (bitvectorType (sz - d))) + Float -> BVToFloat (subFn 0 (bitvectorType 4)) + Double -> BVToDouble (subFn 0 (bitvectorType 8)) + X86_FP80 -> BVToX86_FP80 (subFn 0 (bitvectorType 10)) + Array n0 etp -> assert (n0 > 0) $ do + let esz = storageTypeSize etp + let (c,part) = assert (esz > 0) $ toInteger d `divMod` toInteger esz + let n = toInteger n0 - toInteger c + let o = d - toBytes part -- (Bytes c) * esz + let consPartial + | n < 0 = panic "splitTypeValue" ["Unexpected array size: " ++ show n, show tp, show d] + | part == 0 = subFn o (arrayType (fromInteger n) etp) + | n > 1 = + ConsArray (subFn o etp) + (subFn (o+esz) (arrayType (fromInteger (n-1)) etp)) + | otherwise = assert (n == 1) $ + singletonArray etp (subFn o etp) + let result + | c > 0 = assert (c < toInteger n0) $ + AppendArray (subFn 0 (arrayType (fromInteger c) etp)) + consPartial + | otherwise = consPartial + result + Struct flds -> MkStruct (fldFn <$> flds) + where fldFn fld = (fld, subFn (fieldOffset fld) (fld^.fieldVal)) + +-- | This is used so that when we are comparing symbolic loads against +-- previous stores, we can represent the difference as relative to +-- a fixed address whenever possible. +data BasePreference + = FixedLoad + | FixedStore + | NeitherFixed + deriving (Eq, Show) + +-- RangeLoad + +-- | A 'RangeLoad' describes different kinds of memory loads in the +-- context of a byte range copied into an old memory. +data RangeLoad a b + = OutOfRange a StorageType + -- ^ Load from an address range disjoint from the copied bytes. + -- The arguments represent the address and type of the load. + | InRange b StorageType + -- ^ Load consists of bytes within the copied range. The first + -- argument represents the offset relative to the start of the + -- copied bytes. + deriving (Show) + +adjustOffset :: (b -> d) + -> (a -> c) + -> RangeLoad a b -> RangeLoad c d +adjustOffset _ outFn (OutOfRange a tp) = OutOfRange (outFn a) tp +adjustOffset inFn _ (InRange b tp) = InRange (inFn b) tp + +-- | Decomposes a single load after a memcopy into a combination of +-- simple value loads. +rangeLoad :: + Addr {- ^ load offset -} -> + StorageType {- ^ load type -} -> + Range {- ^ copied range -} -> + ValueCtor (RangeLoad Addr Addr) +rangeLoad lo ltp s@(R so se) + | so == se = loadFail + | le <= so = loadFail + | se <= lo = loadFail + | lo < so = splitTypeValue ltp (so - lo) (\o tp -> rangeLoad (lo+o) tp s) + | se < le = splitTypeValue ltp (se - lo) (\o tp -> rangeLoad (lo+o) tp s) + | otherwise = assert (so <= lo && le <= se) $ ValueCtorVar (InRange (lo - so) ltp) + where le = typeEnd lo ltp + loadFail = ValueCtorVar (OutOfRange lo ltp) + +-- | Produces a @Mux ValueCtor@ expression representing the range load conditions +-- when the load and store offsets are concrete and the store size is bounded +fixedOffsetRangeLoad :: Addr + -- ^ Address of load + -> StorageType + -- ^ Type to load + -> Addr + -- ^ Address of store + -> Mux (ValueCtor (RangeLoad Addr Addr)) +fixedOffsetRangeLoad l tp s + | s < l = do -- Store is before load. + let sd = l - s -- Number of bytes load comes after store + Mux (IntLe StoreSize (CValue sd)) loadFail (loadCase (sd+1)) + | le <= s = loadFail -- No load if load ends before write. + | otherwise = loadCase 0 + where + le = typeEnd l tp + loadCase i + | i < le-s = Mux (IntEq StoreSize (CValue i)) (loadVal i) (loadCase (i+1)) + | otherwise = loadVal i + loadVal ssz = MuxVar (rangeLoad l tp (R s (s+ssz))) + loadFail = MuxVar (ValueCtorVar (OutOfRange l tp)) + +-- | @fixLoadBeforeStoreOffset pref i k@ adjusts a pointer value that is relative +-- the load address into a global pointer. The code assumes that @load + i == store@. +fixLoadBeforeStoreOffset :: BasePreference -> Offset -> Offset -> OffsetExpr +fixLoadBeforeStoreOffset pref i k + | pref == FixedStore = Store .+ CValue (k - i) + | otherwise = Load .+ CValue k + +-- | @fixLoadAfterStoreOffset pref i k@ adjusts a pointer value that is relative +-- the load address into a global pointer. The code assumes that @load == store + i@. +fixLoadAfterStoreOffset :: BasePreference -> Offset -> Offset -> OffsetExpr +fixLoadAfterStoreOffset pref i k = assert (k >= i) $ + case pref of + FixedStore -> Store .+ CValue k + _ -> Load .+ CValue (k - i) + +-- | @loadFromStoreStart pref tp i j@ loads a value of type @tp@ from a range under the +-- assumptions that @load + i == store@ and @j = i + min(StoreSize, typeEnd(tp)@. +loadFromStoreStart :: BasePreference + -> StorageType + -> Offset + -> Offset + -> ValueCtor (RangeLoad OffsetExpr IntExpr) +loadFromStoreStart pref tp i j = adjustOffset inFn outFn <$> rangeLoad 0 tp (R i j) + where inFn = CValue + outFn = fixLoadBeforeStoreOffset pref i + +-- | Produces a @Mux ValueCtor@ expression representing the range load conditions +-- when the load and store values are concrete +fixedSizeRangeLoad :: BasePreference -- ^ Whether addresses are based on store or load. + -> StorageType + -> Bytes + -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr)) +fixedSizeRangeLoad _ tp 0 = MuxVar (ValueCtorVar (OutOfRange Load tp)) +fixedSizeRangeLoad pref tp ssz = + Mux (loadOffset lsz .<= Store) loadFail (prefixL lsz) + where + lsz = typeEnd 0 tp + + prefixL i + | i > 0 = Mux (loadOffset i .== Store) (loadVal i) (prefixL (i-1)) + -- Special case where we skip some offsets, it it won't + -- make more splitting + | lsz <= ssz && pref == NeitherFixed = + -- Load is contained in storage. + Mux (loadInStoreRange (ssz-lsz)) loadSucc $ + -- Load extends past end of storage + suffixS (ssz-lsz) + | otherwise = suffixS 0 + + suffixS i + | i < ssz = Mux (Load .== storeOffset i) (storeVal i) (suffixS (i+1)) + | otherwise = loadFail + + loadVal i = MuxVar (loadFromStoreStart pref tp i (i+ssz)) + + storeVal i = MuxVar (adjustOffset inFn outFn <$> rangeLoad i tp (R 0 ssz)) + where inFn = CValue + outFn = fixLoadAfterStoreOffset pref i + + loadSucc = MuxVar (ValueCtorVar (InRange (Load .- Store) tp)) + loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp)) + +-- | Produces a @Mux ValueCtor@ expression representing the range load conditions +-- when the load and store values are symbolic and the @StoreSize@ is bounded. +symbolicRangeLoad :: BasePreference -> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr)) +symbolicRangeLoad pref tp = + Mux (Store .<= Load) + (Mux (loadOffset sz .<= storeEnd) (loadVal0 sz) (loadIter0 (sz-1))) + (storeAfterLoad 1) + where + sz = typeEnd 0 tp + + loadIter0 j + | j > 0 = Mux (loadOffset j .== storeEnd) (loadVal0 j) (loadIter0 (j-1)) + | otherwise = loadFail + + loadVal0 j = MuxVar $ adjustOffset inFn outFn <$> rangeLoad 0 tp (R 0 j) + where inFn k = IntAdd (OffsetDiff Load Store) (CValue k) + outFn k = OffsetAdd Load (CValue k) + + storeAfterLoad i + | i < sz = Mux (loadOffset i .== Store) (loadFromOffset i) (storeAfterLoad (i+1)) + | otherwise = loadFail + + loadFromOffset i = + assert (0 < i && i < sz) $ + Mux (IntLe (CValue (sz - i)) StoreSize) (loadVal i (i+sz)) (f (sz-1)) + where f j | j > i = Mux (IntEq (CValue (j-i)) StoreSize) (loadVal i j) (f (j-1)) + | otherwise = loadFail + + loadVal i j = MuxVar (loadFromStoreStart pref tp i j) + loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp)) + +-- | Produces a @Mux ValueCtor@ expression representing the RangeLoad conditions +-- when the load and store values are symbolic and the @StoreSize@ is unbounded. +symbolicUnboundedRangeLoad :: BasePreference -> StorageType -> Mux (ValueCtor (RangeLoad OffsetExpr IntExpr)) +symbolicUnboundedRangeLoad pref tp = + Mux (Store .<= Load) + (loadVal0 sz) + (storeAfterLoad 1) + where + sz = typeEnd 0 tp + + loadVal0 j = MuxVar $ adjustOffset inFn outFn <$> rangeLoad 0 tp (R 0 j) + where inFn k = IntAdd (OffsetDiff Load Store) (CValue k) + outFn k = OffsetAdd Load (CValue k) + + storeAfterLoad i + | i < sz = Mux (loadOffset i .== Store) (loadFromOffset i) (storeAfterLoad (i+1)) + | otherwise = loadFail + + loadFromOffset i = + assert (0 < i && i < sz) $ + Mux (IntLe (CValue (sz - i)) StoreSize) (loadVal i (i+sz)) (f (sz-1)) + where f j | j > i = Mux (IntEq (CValue (j-i)) StoreSize) (loadVal i j) (f (j-1)) + | otherwise = loadFail + + loadVal i j = MuxVar (loadFromStoreStart pref tp i j) + loadFail = MuxVar (ValueCtorVar (OutOfRange Load tp)) + +-- ValueView + +-- | Represents a projection of a sub-component out of a larger LLVM value. +data ValueView + = ValueViewVar StorageType + -- | Select low-address bytes in the bitvector. + -- The sizes include the number of low bytes, and the number of high bytes. + | SelectPrefixBV Bytes Bytes ValueView + -- | Select the given number of high-address bytes in the bitvector. + -- The sizes include the number of low bytes, and the number of high bytes. + | SelectSuffixBV Bytes Bytes ValueView + | FloatToBV ValueView + | DoubleToBV ValueView + | X86_FP80ToBV ValueView + | ArrayElt Natural StorageType Natural ValueView + + | FieldVal (Vector (Field StorageType)) Int ValueView + deriving (Show, Eq, Ord) + +viewType :: ValueView -> Maybe StorageType +viewType (ValueViewVar tp) = Just tp +viewType (SelectPrefixBV u v vv) = + do tp <- storageTypeF <$> viewType vv + guard (Bitvector (u + v) == tp) + pure $ bitvectorType u +viewType (SelectSuffixBV u v vv) = + do tp <- storageTypeF <$> viewType vv + guard (Bitvector (u + v) == tp) + pure $ bitvectorType v +viewType (FloatToBV vv) = + do tp <- storageTypeF <$> viewType vv + guard (Float == tp) + pure $ bitvectorType 4 +viewType (DoubleToBV vv) = + do tp <- storageTypeF <$> viewType vv + guard (Double == tp) + pure $ bitvectorType 8 +viewType (X86_FP80ToBV vv) = + do tp <- storageTypeF <$> viewType vv + guard (X86_FP80 == tp) + pure $ bitvectorType 10 +viewType (ArrayElt n etp i vv) = + do tp <- storageTypeF <$> viewType vv + guard (i < n && Array n etp == tp) + pure $ etp +viewType (FieldVal v i vv) = + do tp <- storageTypeF <$> viewType vv + guard (Struct v == tp) + view fieldVal <$> (v V.!? i) + +-- | A 'ValueLoad' describes different kinds of memory loads in the +-- context of a new value stored into an old memory. +data ValueLoad v + = OldMemory v StorageType + -- ^ Load from an address range disjoint from the stored value. + -- The arguments represent the address and type of the load. + | LastStore ValueView + -- ^ Load consists of valid bytes within the stored value. + | InvalidMemory StorageType + -- ^ Load touches invalid memory. Currently, this can only arise when + -- trying to read struct padding bytes as a bitvector. + deriving (Functor,Show) + +loadBitvector :: Addr -> Bytes -> Addr -> ValueView -> ValueCtor (ValueLoad Addr) +loadBitvector lo lw so v = do + let le = lo + lw + let ltp = bitvectorType lw + let stp = fromMaybe (error ("loadBitvector given bad view " ++ show v)) (viewType v) + let retValue eo v' = (sz', valueLoad lo' (bitvectorType sz') eo v') + where etp = fromMaybe (error ("Bad view " ++ show v')) (viewType v') + esz = storageTypeSize etp + lo' = max lo eo + sz' = min le (eo+esz) - lo' + case storageTypeF stp of + Bitvector sw + | so < lo -> do + -- Number of bytes to drop. + let d = lo - so + -- Store is before load. + valueLoad lo ltp lo (SelectSuffixBV d (sw - d) v) + | otherwise -> assert (lo == so && lw < sw) $ + -- Load ends before store ends. + valueLoad lo ltp so (SelectPrefixBV lw (sw - lw) v) + Float -> valueLoad lo ltp so (FloatToBV v) + Double -> valueLoad lo ltp so (DoubleToBV v) + X86_FP80 -> valueLoad lo ltp so (X86_FP80ToBV v) + Array n tp -> snd $ foldl1 cv (val <$> r) + where cv (wx,x) (wy,y) = (wx + wy, concatBV wx x wy y) + esz = storageTypeSize tp + c0 = assert (esz > 0) $ toInteger (lo - so) `div` toInteger esz + (c1, p1) = toInteger (le - so) `divMod` toInteger esz + -- Get range of indices to read. + r | p1 == 0 = assert (c1 > c0) [c0..c1-1] + | otherwise = assert (c1 >= c0) [c0..c1] + val i + | i >= 0 = retValue (so + natBytesMul (fromInteger i) esz) (ArrayElt n tp (fromInteger i) v) + | otherwise = panic "loadBitvector" ["Bad array index", show i, show (lo, lw, so, v)] + Struct sflds -> assert (not (null r)) $ snd $ foldl1 cv r + where cv (wx,x) (wy,y) = (wx+wy, concatBV wx x wy y) + r = concat (zipWith val [0..] (V.toList sflds)) + val i f = v1 + where eo = so + fieldOffset f + ee = eo + storageTypeSize (f^.fieldVal) + v1 | le <= eo = v2 + | ee <= lo = v2 + | otherwise = retValue eo (FieldVal sflds i v) : v2 + v2 | fieldPad f == 0 = [] -- Return no padding. + | le <= ee = [] -- Nothing of load ends before padding. + -- Nothing if padding ends before load begins. + | ee+fieldPad f <= lo = [] + | otherwise = [(p, ValueCtorVar badMem)] + where p = min (ee+fieldPad f) le - (max lo ee) + tpPad = bitvectorType p + badMem = InvalidMemory tpPad + +-- | Decomposes a single load after a store into a combination of +-- simple value loads. +valueLoad :: + Addr {- ^ load address -} -> + StorageType {- ^ load type -} -> + Addr {- ^ store address -} -> + ValueView {- ^ view of stored value -} -> + ValueCtor (ValueLoad Addr) +valueLoad lo ltp so v + | le <= so = ValueCtorVar (OldMemory lo ltp) -- Load ends before store + | se <= lo = ValueCtorVar (OldMemory lo ltp) -- Store ends before load + -- Load is before store. + | lo < so = splitTypeValue ltp (so - lo) (\o tp -> valueLoad (lo+o) tp so v) + -- Load ends after store ends. + | se < le = splitTypeValue ltp (le - se) (\o tp -> valueLoad (lo+o) tp so v) + | (lo,ltp) == (so,stp) = ValueCtorVar (LastStore v) + | otherwise = + case storageTypeF ltp of + Bitvector lw -> loadBitvector lo lw so v + Float -> BVToFloat $ valueLoad lo (bitvectorType 4) so v + Double -> BVToDouble $ valueLoad lo (bitvectorType 8) so v + X86_FP80 -> BVToX86_FP80 $ valueLoad lo (bitvectorType 10) so v + Array ln tp -> + let leSize = storageTypeSize tp + val i = valueLoad (lo+leSize*fromIntegral i) tp so v + in MkArray tp (V.generate (fromIntegral ln) val) + Struct lflds -> + let val f = (f, valueLoad (lo+fieldOffset f) (f^.fieldVal) so v) + in MkStruct (val <$> lflds) + where stp = fromMaybe (error ("Coerce value given bad view " ++ show v)) (viewType v) + le = typeEnd lo ltp + se = so + storageTypeSize stp + +-- | @LinearLoadStoreOffsetDiff stride delta@ represents the fact that +-- the difference between the load offset and the store offset is +-- of the form @stride * n + delta@ for some integer @n@, where +-- @stride@ and @delta@ are non-negative integers, and @n@ can be +-- positive, negative, or zero. If no form if known, then @stride@ is @1@ +-- and @delta@ is @0@. +data LinearLoadStoreOffsetDiff = LinearLoadStoreOffsetDiff Bytes Bytes + +-- | This function computes a mux tree value for loading a chunk from inside +-- a previously-written value. The @StorageType@ of the load indicates +-- the size of the loaded value and how we intend to view it. The bounds, +-- if provided, are bounds on the difference between the load pointer and the +-- store pointer. Postive values indicate the Load offset is larger than the +-- store offset. These bounds, if provided, are used to shrink the size of +-- the computed mux tree, and can lead to significantly smaller results. +-- The @ValueView@ is the syntactic representation of the value being +-- loaded from. The @LinearLoadStoreOffsetDiff@ form further reduces the size +-- of the mux tree by only considering (load offset - store offset) values of +-- the given form. +symbolicValueLoad :: + BasePreference {- ^ whether addresses are based on store or load -} -> + StorageType {- ^ load type -} -> + Maybe (Integer, Integer) {- ^ optional bounds on the offset between load and store -} -> + ValueView {- ^ view of stored value -} -> + LinearLoadStoreOffsetDiff {- ^ linear (load offset - store offset) form -} -> + Mux (ValueCtor (ValueLoad OffsetExpr)) +symbolicValueLoad pref tp bnd v (LinearLoadStoreOffsetDiff stride delta) = + Mux (Or (loadOffset lsz .<= Store) (storeOffset (storageTypeSize stp) .<= Load)) loadFail $ + MuxTable Load Store prefixTable $ + MuxTable Store Load suffixTable loadFail + where + lsz = typeEnd 0 tp + stp = case viewType v of + Just x -> x + Nothing -> panic "crucible-llvm:symbolicValueLoad" + [ "Unable obtain type of stored value ValueView" ] + + -- The prefix table represents cases where the load pointer occurs strictly before the + -- write pointer, so that the end of the load may be partially satisfied by this write. + prefixTable = mkPrefixTable prefixLoBound + + -- The suffix table represents cases where the load pointer occurs at or after the write + -- pointer so that the load is fully satisfied or the beginning is partially satisfied + -- by this write. + suffixTable = mkSuffixTable suffixLoBound + + -- The smallest (non-negative) offset value that can occur in the suffix table. + -- This is either 0 (load = store) or is given by the difference bound when + -- the low value is positive. + suffixLoBound = + case bnd of + Just (lo, _hi) + | lo > 0 -> adjustLoBound delta (toBytes lo) + _ -> delta + + -- One past the largest offset value that can occur in the suffix table. + -- This is either the length of the written value, or is given by the + -- difference bound. Note, in the case @hi@ is negative, the suffix table + -- will be empty. + suffixHiBound = + case bnd of + Just (_lo, hi) + | hi >= 0 -> min (storageTypeSize stp) (toBytes hi + 1) + | otherwise -> 0 + _ -> storageTypeSize stp + + -- The smallest magnitude of offset that the load may occur + -- behind the write pointer. This is at least the stride of the alignment, + -- but may also be given by the high bound value of the difference, if it is negative. + prefixLoBound = + case bnd of + Just (_lo, hi) + | hi < 0 -> adjustLoBound (stride - delta) (toBytes (-hi)) + _ -> stride - delta + + -- The largest magnitude of offset, plus one, that the load may occur + -- behind the write pointer. This is at most the length of the read, + -- but may also be given by the low bound value of the offset difference, + -- if it is negative. Note, in the case that @lo@ is positive, the + -- prefix table will be empty. + prefixHiBound = + case bnd of + Just (lo, _hi) + | lo < 0 -> min lsz (toBytes (-lo) + 1) + | otherwise -> 0 + _ -> lsz + + -- Walk through prefix offset values, computing a mux tree of the values + -- for those prefix loads. + mkPrefixTable :: Bytes -> Map Bytes (Mux (ValueCtor (ValueLoad OffsetExpr))) + mkPrefixTable i + | i < prefixHiBound = Map.insert i + (MuxVar (fmap adjustFn <$> valueLoad 0 tp i v)) + (mkPrefixTable (i + stride)) + | otherwise = Map.empty + where adjustFn = fixLoadBeforeStoreOffset pref i + + -- Walk through suffix offset values, computing a mux tree of the values + -- for those suffix loads. + mkSuffixTable :: Bytes -> Map Bytes (Mux (ValueCtor (ValueLoad OffsetExpr))) + mkSuffixTable i + | i < suffixHiBound = + Map.insert i + (MuxVar (fmap adjustFn <$> valueLoad i tp 0 v)) + (mkSuffixTable (i + stride)) + | otherwise = Map.empty + where adjustFn = fixLoadAfterStoreOffset pref i + + loadFail = MuxVar (ValueCtorVar (OldMemory Load tp)) + + adjustLoBound :: Bytes -> Bytes -> Bytes + adjustLoBound i bound = if i >= bound + then i + else adjustLoBound (i + stride) bound + +-- | Create a value of the given type made up of copies of the given byte. +memsetValue :: a -> StorageType -> ValueCtor a +memsetValue byte = go + where + val = ValueCtorVar byte + go tp = + case storageTypeF tp of + Bitvector sz + | sz <= 1 -> val + | otherwise -> concatBV 1 val (sz - 1) (go (bitvectorType (sz - 1))) + Float -> BVToFloat (go (bitvectorType 4)) + Double -> BVToDouble (go (bitvectorType 8)) + X86_FP80 -> BVToX86_FP80 (go (bitvectorType 10)) + Array n etp -> MkArray etp (V.replicate (fromIntegral n) (go etp)) + Struct flds -> MkStruct (fldFn <$> flds) + where fldFn fld = (fld, go (fld^.fieldVal)) + +-- | Create value of type that splits at a particular byte offset. +-- +-- This function uses the given 'StorageType' to determine how many bytes to +-- read (including accounting for padding in struct types). The function to +-- load each byte is provided as an argument. +-- +-- NOTE: The 'Offset' argument is not necessarily the offset into the +-- allocation; it *could* be zero if the load function captures the offset into +-- the allocation. +loadTypedValueFromBytes + :: Offset -- ^ The initial offset to pass to the byte loading function + -> StorageType -- ^ The type used to compute how many bytes to read + -> (Offset -> IO a) -- ^ A function to read individual bytes (at the given offset) + -> IO (ValueCtor a) +loadTypedValueFromBytes off tp subFn = case storageTypeF tp of + Bitvector size + | size <= 1 -> ValueCtorVar <$> subFn off + | otherwise -> do + head_byte <- ValueCtorVar <$> subFn off + tail_bytes <- loadTypedValueFromBytes + (off + 1) + (bitvectorType (size - 1)) + subFn + return $ concatBV 1 head_byte (size - 1) tail_bytes + Float -> + BVToFloat <$> loadTypedValueFromBytes off (bitvectorType 4) subFn + Double -> + BVToDouble <$> loadTypedValueFromBytes off (bitvectorType 8) subFn + X86_FP80 -> + BVToX86_FP80 <$> loadTypedValueFromBytes off (bitvectorType 10) subFn + Array len elem_type -> MkArray elem_type <$> V.generateM + (fromIntegral len) + (\idx -> loadTypedValueFromBytes + (off + (fromIntegral idx) * (storageTypeSize elem_type)) + elem_type + subFn) + Struct fields -> MkStruct <$> V.mapM + (\field -> do + field_val <- loadTypedValueFromBytes + (off + (fieldOffset field)) + (field^.fieldVal) + subFn + return (field, field_val)) + fields diff --git a/src/Lang/Crucible/LLVM/MemModel/Generic.hs b/src/Lang/Crucible/LLVM/MemModel/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Generic.hs @@ -0,0 +1,1808 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Generic +-- Description : Core definitions of the symbolic C memory model +-- Copyright : (c) Galois, Inc 2011-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} + +module Lang.Crucible.LLVM.MemModel.Generic + ( Mem + , emptyMem + , AllocType(..) + , Mutability(..) + , AllocInfo(..) + , MemAllocs + , memAllocs + , memEndian + , memAllocCount + , memWriteCount + , allocMem + , allocAndWriteMem + , readMem + , isValidPointer + , isAllocatedMutable + , isAllocatedAlignedPointer + , notAliasable + , writeMem + , writeConstMem + , copyMem + , setMem + , invalidateMem + , writeArrayMem + , writeArrayConstMem + , pushStackFrameMem + , popStackFrameMem + , freeMem + , branchMem + , branchAbortMem + , mergeMem + , asMemAllocationArrayStore + , isAligned + + , SomeAlloc(..) + , possibleAllocs + , possibleAllocInfo + , ppSomeAlloc + + -- * Pretty printing + , ppType + , ppPtr + , ppAllocs + , ppMem + , ppTermExpr + ) where + +import Prelude hiding (pred) + +import Control.Lens +import Control.Monad +import Control.Monad.State.Strict +import Data.IORef +import Data.Maybe +import qualified Data.List as List +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Monoid +import Data.Text (Text) +import Numeric.Natural +import Prettyprinter +import Lang.Crucible.Panic (panic) + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Ctx (SingleCtx) +import Data.Parameterized.Some + +import What4.Interface +import qualified What4.Concrete as W4 + +import Lang.Crucible.Backend +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.Errors.MemoryError (MemErrContext, MemoryErrorReason(..), MemoryOp(..)) +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.MemModel.CallStack (getCallStack) +import Lang.Crucible.LLVM.MemModel.Common +import Lang.Crucible.LLVM.MemModel.Options +import Lang.Crucible.LLVM.MemModel.MemLog +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemModel.Type +import Lang.Crucible.LLVM.MemModel.Value +import Lang.Crucible.LLVM.MemModel.Partial (PartLLVMVal, HasLLVMAnn) +import qualified Lang.Crucible.LLVM.MemModel.Partial as Partial +import Lang.Crucible.LLVM.Utils +import Lang.Crucible.Simulator.RegMap (RegValue'(..)) + +-------------------------------------------------------------------------------- +-- Reading from memory + +tgAddPtrC :: (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> LLVMPtr sym w -> Addr -> IO (LLVMPtr sym w) +tgAddPtrC sym w x y = ptrAdd sym w x =<< constOffset sym w y + +-- | An environment used to interpret 'OffsetExpr's, 'IntExpr's, and 'Cond's. +-- These data structures may contain uninterpreted variables to be filled in +-- with the offset address of a load or store, or the size of the current +-- region. Since regions may be unbounded in size, the size argument is a +-- 'Maybe' type. +data ExprEnv sym w = ExprEnv { loadOffset :: SymBV sym w + , storeOffset :: SymBV sym w + , sizeData :: Maybe (SymBV sym w) } + +ppExprEnv :: IsExprBuilder sym => ExprEnv sym w -> Doc ann +ppExprEnv f = + vcat + [ "ExprEnv" + , indent 4 $ vcat + [ "loadOffset:" <+> printSymExpr (loadOffset f) + , "storeOffset:" <+> printSymExpr (storeOffset f) + , "sizeData:" <+> maybe mempty printSymExpr (sizeData f) + ] + ] + +-- | Interpret an 'OffsetExpr' as a 'SymBV'. Although 'OffsetExpr's may contain +-- 'IntExpr's, which may be undefined if they refer to the size of an unbounded +-- memory region, this function will panic if both (1) the 'sizeData' +-- in the 'ExprEnv' is 'Nothing' and (2) 'StoreSize' occurs anywhere in the +-- 'OffsetExpr'. +genOffsetExpr :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + ExprEnv sym w -> + OffsetExpr -> + IO (SymBV sym w) +genOffsetExpr sym w f@(ExprEnv load store _size) expr = + case expr of + OffsetAdd pe ie -> do + pe' <- genOffsetExpr sym w f pe + ie' <- genIntExpr sym w f ie + case ie' of + Nothing -> panic "Generic.genOffsetExpr" + [ "Cannot construct an offset that references the size of an unbounded region" + , "*** Invalid offset expression: " ++ show expr + , "*** Under environment: " ++ show (ppExprEnv f) + ] + Just ie'' -> bvAdd sym pe' ie'' + Load -> return load + Store -> return store + +-- | Interpret an 'IntExpr' as a 'SymBV'. If the 'IntExpr' contains an +-- occurrence of 'StoreSize' and the store size in the 'ExprEnv' is unbounded, +-- will return 'Nothing'. +genIntExpr :: + (1 <= w, IsSymInterface sym) => + sym -> + NatRepr w -> + ExprEnv sym w -> + IntExpr -> + IO (Maybe (SymBV sym w)) +genIntExpr sym w f@(ExprEnv _load _store size) expr = + case expr of + OffsetDiff e1 e2 -> do + e1' <- genOffsetExpr sym w f e1 + e2' <- genOffsetExpr sym w f e2 + Just <$> bvSub sym e1' e2' + IntAdd e1 e2 -> do + e1' <- genIntExpr sym w f e1 + e2' <- genIntExpr sym w f e2 + case (e1', e2') of + (Just e1'', Just e2'') -> Just <$> bvAdd sym e1'' e2'' + _ -> return Nothing -- Unbounded space added to anything is unbounded + CValue i -> Just <$> bvLit sym w (bytesToBV w i) + StoreSize -> return size + +-- | Interpret a conditional as a symbolic predicate. +genCondVar :: forall sym w. + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + ExprEnv sym w -> + Cond -> + IO (Pred sym) +genCondVar sym w inst c = + case c of + OffsetEq x y -> join $ bvEq sym <$> genOffsetExpr sym w inst x <*> genOffsetExpr sym w inst y + OffsetLe x y -> join $ bvUle sym <$> genOffsetExpr sym w inst x <*> genOffsetExpr sym w inst y + IntEq x y -> join $ maybeBVEq sym <$> genIntExpr sym w inst x <*> genIntExpr sym w inst y + IntLe x y -> join $ maybeBVLe sym <$> genIntExpr sym w inst x <*> genIntExpr sym w inst y + And x y -> join $ andPred sym <$> genCondVar sym w inst x <*> genCondVar sym w inst y + Or x y -> join $ orPred sym <$> genCondVar sym w inst x <*> genCondVar sym w inst y + +-- | Compare the equality of two @Maybe SymBV@s +maybeBVEq :: (1 <= w, IsExprBuilder sym) + => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym) +maybeBVEq sym (Just x) (Just y) = bvEq sym x y +maybeBVEq sym Nothing Nothing = return $ truePred sym +maybeBVEq sym _ _ = return $ falsePred sym + +-- | Compare two @Maybe SymBV@s +maybeBVLe :: (1 <= w, IsExprBuilder sym) + => sym -> Maybe (SymBV sym w) -> Maybe (SymBV sym w) -> IO (Pred sym) +maybeBVLe sym (Just x) (Just y) = bvSle sym x y +maybeBVLe sym _ Nothing = return $ truePred sym +maybeBVLe sym Nothing (Just _) = return $ falsePred sym + +-- | Given a 'ValueCtor' (of partial LLVM values), recursively traverse the +-- 'ValueCtor' to reconstruct the partial value as directed (while respecting +-- endianness) +genValueCtor :: forall sym w. + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + EndianForm -> + MemoryOp sym w -> + ValueCtor (PartLLVMVal sym) -> + IO (PartLLVMVal sym) +genValueCtor sym end errCtx v = + case v of + ValueCtorVar x -> return x + ConcatBV vcl vch -> + do vl <- genValueCtor sym end errCtx vcl + vh <- genValueCtor sym end errCtx vch + case end of + BigEndian -> Partial.bvConcat sym errCtx vh vl + LittleEndian -> Partial.bvConcat sym errCtx vl vh + ConsArray vc1 vc2 -> + do lv1 <- genValueCtor sym end errCtx vc1 + lv2 <- genValueCtor sym end errCtx vc2 + Partial.consArray sym errCtx lv1 lv2 + AppendArray vc1 vc2 -> + do lv1 <- genValueCtor sym end errCtx vc1 + lv2 <- genValueCtor sym end errCtx vc2 + Partial.appendArray sym errCtx lv1 lv2 + MkArray tp vv -> + Partial.mkArray sym tp =<< + traverse (genValueCtor sym end errCtx) vv + MkStruct vv -> + Partial.mkStruct sym =<< + traverse (traverse (genValueCtor sym end errCtx)) vv + BVToFloat x -> + Partial.bvToFloat sym errCtx =<< genValueCtor sym end errCtx x + BVToDouble x -> + Partial.bvToDouble sym errCtx =<< genValueCtor sym end errCtx x + BVToX86_FP80 x -> + Partial.bvToX86_FP80 sym errCtx =<< genValueCtor sym end errCtx x + +-- | Compute the actual value of a value deconstructor expression. +applyView :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + EndianForm -> + MemErrContext sym w -> + PartLLVMVal sym -> + ValueView -> + IO (PartLLVMVal sym) +applyView sym end errCtx t val = + case val of + ValueViewVar _ -> + return t + SelectPrefixBV i j v -> + do t' <- applyView sym end errCtx t v + case end of + BigEndian -> Partial.selectHighBv sym errCtx j i t' + LittleEndian -> Partial.selectLowBv sym errCtx i j t' + SelectSuffixBV i j v -> + do t' <- applyView sym end errCtx t v + case end of + BigEndian -> Partial.selectLowBv sym errCtx j i t' + LittleEndian -> Partial.selectHighBv sym errCtx i j t' + FloatToBV v -> + Partial.floatToBV sym errCtx =<< applyView sym end errCtx t v + DoubleToBV v -> + Partial.doubleToBV sym errCtx =<< applyView sym end errCtx t v + X86_FP80ToBV v -> + Partial.fp80ToBV sym errCtx =<< applyView sym end errCtx t v + ArrayElt sz tp idx v -> + Partial.arrayElt sym errCtx sz tp idx =<< applyView sym end errCtx t v + FieldVal flds idx v -> + Partial.fieldVal sym errCtx flds idx =<< applyView sym end errCtx t v + +evalMuxValueCtor :: + forall u sym w . + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + sym -> + NatRepr w -> + EndianForm -> + MemErrContext sym w -> + ExprEnv sym w {- ^ Evaluation function -} -> + (u -> ReadMem sym (PartLLVMVal sym)) {- ^ Function for reading specific subranges -} -> + Mux (ValueCtor u) -> + ReadMem sym (PartLLVMVal sym) +evalMuxValueCtor sym _w end errCtx _vf subFn (MuxVar v) = + do v' <- traverse subFn v + liftIO $ genValueCtor sym end errCtx v' +evalMuxValueCtor sym w end errCtx vf subFn (Mux c t1 t2) = + do c' <- liftIO $ genCondVar sym w vf c + case asConstantPred c' of + Just True -> evalMuxValueCtor sym w end errCtx vf subFn t1 + Just False -> evalMuxValueCtor sym w end errCtx vf subFn t2 + Nothing -> + do t1' <- evalMuxValueCtor sym w end errCtx vf subFn t1 + t2' <- evalMuxValueCtor sym w end errCtx vf subFn t2 + liftIO $ Partial.muxLLVMVal sym c' t1' t2' + +evalMuxValueCtor sym w end errCtx vf subFn (MuxTable a b m t) = + do m' <- traverse (evalMuxValueCtor sym w end errCtx vf subFn) m + t' <- evalMuxValueCtor sym w end errCtx vf subFn t + -- TODO: simplification? + Map.foldrWithKey f (return t') m' + where + f :: Bytes -> PartLLVMVal sym -> ReadMem sym (PartLLVMVal sym) -> ReadMem sym (PartLLVMVal sym) + f n t1 k = + do c' <- liftIO $ genCondVar sym w vf (OffsetEq (aOffset n) b) + case asConstantPred c' of + Just True -> return t1 + Just False -> k + Nothing -> liftIO . Partial.muxLLVMVal sym c' t1 =<< k + + aOffset :: Bytes -> OffsetExpr + aOffset n = OffsetAdd a (CValue n) + +-- | Read from a memory with a memcopy to the same block we are reading. +readMemCopy :: + forall sym w. + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + sym -> + NatRepr w -> + EndianForm -> + MemoryOp sym w -> + LLVMPtr sym w {- ^ The loaded offset -} -> + StorageType {- ^ The type we are reading -} -> + SymBV sym w {- ^ The destination of the memcopy -} -> + LLVMPtr sym w {- ^ The source of the copied region -} -> + SymBV sym w {- ^ The length of the copied region -} -> + (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) -> + ReadMem sym (PartLLVMVal sym) +readMemCopy sym w end mop (LLVMPointer blk off) tp d src sz readPrev = + do let ld = BV.asUnsigned <$> asBV off + let dd = BV.asUnsigned <$> asBV d + let varFn = ExprEnv off d (Just sz) + + case (ld, dd) of + -- Offset if known + (Just lo, Just so) -> + do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = do + o' <- liftIO $ bvLit sym w (bytesToBV w o) + readPrev tp' (LLVMPointer blk o') + subFn (InRange o tp') = + readPrev tp' =<< liftIO (tgAddPtrC sym w src o) + case BV.asUnsigned <$> asBV sz of + Just csz -> do + let s = R (fromInteger so) (fromInteger (so + csz)) + let vcr = rangeLoad (fromInteger lo) tp s + liftIO . genValueCtor sym end mop =<< traverse subFn vcr + _ -> + evalMuxValueCtor sym w end mop varFn subFn $ + fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so) + -- Symbolic offsets + _ -> + do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = + do o' <- liftIO $ genOffsetExpr sym w varFn o + readPrev tp' (LLVMPointer blk o') + subFn (InRange o tp') = do + oExpr <- liftIO $ genIntExpr sym w varFn o + srcPlusO <- case oExpr of + Just oExpr' -> liftIO $ ptrAdd sym w src oExpr' + Nothing -> panic "Generic.readMemCopy" + ["Cannot use an unbounded bitvector expression as an offset" + ,"*** In offset epxression: " ++ show o + ,"*** Under environment: " ++ show (ppExprEnv varFn) + ] + readPrev tp' srcPlusO + let pref | Just{} <- dd = FixedStore + | Just{} <- ld = FixedLoad + | otherwise = NeitherFixed + let mux0 | Just csz <- BV.asUnsigned <$> asBV sz = + fixedSizeRangeLoad pref tp (fromInteger csz) + | otherwise = + symbolicRangeLoad pref tp + evalMuxValueCtor sym w end mop varFn subFn mux0 + +readMemSet :: + forall sym w . + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + sym -> + NatRepr w -> + EndianForm -> + MemoryOp sym w -> + LLVMPtr sym w {- ^ The loaded offset -} -> + StorageType {- ^ The type we are reading -} -> + SymBV sym w {- ^ The destination of the memset -} -> + SymBV sym 8 {- ^ The fill byte that was set -} -> + SymBV sym w {- ^ The length of the set region -} -> + (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) -> + ReadMem sym (PartLLVMVal sym) +readMemSet sym w end mop (LLVMPointer blk off) tp d byte sz readPrev = + do let ld = BV.asUnsigned <$> asBV off + let dd = BV.asUnsigned <$> asBV d + let varFn = ExprEnv off d (Just sz) + case (ld, dd) of + -- Offset if known + (Just lo, Just so) -> + do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = do + o' <- liftIO $ bvLit sym w (bytesToBV w o) + readPrev tp' (LLVMPointer blk o') + subFn (InRange _o tp') = do + blk0 <- liftIO $ natLit sym 0 + let val = LLVMValInt blk0 byte + let b = Partial.totalLLVMVal sym val + liftIO $ genValueCtor sym end mop (memsetValue b tp') + case BV.asUnsigned <$> asBV sz of + Just csz -> do + let s = R (fromInteger so) (fromInteger (so + csz)) + let vcr = rangeLoad (fromInteger lo) tp s + liftIO . genValueCtor sym end mop =<< traverse subFn vcr + _ -> evalMuxValueCtor sym w end mop varFn subFn $ + fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so) + -- Symbolic offsets + _ -> + do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = + do o' <- liftIO $ genOffsetExpr sym w varFn o + readPrev tp' (LLVMPointer blk o') + subFn (InRange _o tp') = liftIO $ + do blk0 <- natLit sym 0 + let val = LLVMValInt blk0 byte + let b = Partial.totalLLVMVal sym val + genValueCtor sym end mop (memsetValue b tp') + let pref | Just{} <- dd = FixedStore + | Just{} <- ld = FixedLoad + | otherwise = NeitherFixed + let mux0 | Just csz <- BV.asUnsigned <$> asBV sz = + fixedSizeRangeLoad pref tp (fromInteger csz) + | otherwise = + symbolicRangeLoad pref tp + evalMuxValueCtor sym w end mop varFn subFn mux0 + +-- | Read from a memory with a store to the same block we are reading. +readMemStore :: + forall sym w. + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + sym -> + NatRepr w -> + EndianForm -> + MemoryOp sym w -> + LLVMPtr sym w {- ^ The loaded address -} -> + StorageType {- ^ The type we are reading -} -> + SymBV sym w {- ^ The destination of the store -} -> + LLVMVal sym {- ^ The value that was stored -} -> + StorageType {- ^ The type of value that was written -} -> + Alignment {- ^ The alignment of the pointer we are reading from -} -> + Alignment {- ^ The alignment of the store from which we are reading -} -> + (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) + {- ^ A callback function for when reading fails -} -> + ReadMem sym (PartLLVMVal sym) +readMemStore sym w end mop (LLVMPointer blk off) ltp d t stp loadAlign storeAlign readPrev = + do ssz <- liftIO $ bvLit sym w (bytesToBV w (storageTypeSize stp)) + let varFn = ExprEnv off d (Just ssz) + let ld = BV.asUnsigned <$> asBV off + let dd = BV.asUnsigned <$> asBV d + case (ld, dd) of + -- Offset if known + (Just lo, Just so) -> + do let subFn :: ValueLoad Addr -> ReadMem sym (PartLLVMVal sym) + subFn (OldMemory o tp') = + readPrev tp' . LLVMPointer blk =<< + liftIO (bvLit sym w (bytesToBV w o)) + subFn (LastStore v) = liftIO $ + applyView sym end mop (Partial.totalLLVMVal sym t) v + subFn (InvalidMemory tp) = liftIO (Partial.partErr sym mop $ Invalid tp) + let vcr = valueLoad (fromInteger lo) ltp (fromInteger so) (ValueViewVar stp) + liftIO . genValueCtor sym end mop =<< traverse subFn vcr + -- Symbolic offsets + _ -> + do let subFn :: ValueLoad OffsetExpr -> ReadMem sym (PartLLVMVal sym) + subFn (OldMemory o tp') = do + o' <- liftIO $ genOffsetExpr sym w varFn o + readPrev tp' (LLVMPointer blk o') + subFn (LastStore v) = liftIO $ + applyView sym end mop (Partial.totalLLVMVal sym t) v + subFn (InvalidMemory tp) = liftIO (Partial.partErr sym mop $ Invalid tp) + let pref | Just{} <- dd = FixedStore + | Just{} <- ld = FixedLoad + | otherwise = NeitherFixed + + let alignStride = fromAlignment $ min loadAlign storeAlign + + -- compute the linear form of (load offset - store offset) + let (diffStride, diffDelta) + | Just (load_a, _x, load_b) <- asAffineVar off + , Just (store_a, _y, store_b) <- asAffineVar d = do + let stride' = gcd + (BV.asUnsigned (W4.fromConcreteBV load_a)) + (BV.asUnsigned (W4.fromConcreteBV store_a)) + -- mod returns a non-negative integer + let delta' = mod + (BV.asUnsigned (W4.fromConcreteBV load_b) - + BV.asUnsigned (W4.fromConcreteBV store_b)) + stride' + (fromInteger stride', fromInteger delta') + | Just (load_a, _x, load_b) <- asAffineVar off + , Just store_b <- BV.asUnsigned <$> asBV d = do + let stride' = BV.asUnsigned (W4.fromConcreteBV load_a) + let delta' = mod (BV.asUnsigned (W4.fromConcreteBV load_b) - store_b) stride' + (fromInteger stride', fromInteger delta') + | Just load_b <- BV.asUnsigned <$> asBV off + , Just (store_a, _y, store_b) <- asAffineVar d = do + let stride' = BV.asUnsigned (W4.fromConcreteBV store_a) + let delta' = mod (load_b - BV.asUnsigned (W4.fromConcreteBV store_b)) stride' + (fromInteger stride', fromInteger delta') + | otherwise = (1, 0) + + let (stride, delta) = if diffStride >= alignStride + then (diffStride, diffDelta) + else (alignStride, 0) + + diff <- liftIO $ bvSub sym off d + + -- skip computing the mux tree if it would be empty + if storageTypeSize stp <= delta && (typeEnd 0 ltp) <= (stride - delta) + then readPrev ltp $ LLVMPointer blk off + else evalMuxValueCtor sym w end mop varFn subFn $ + symbolicValueLoad + pref + ltp + (signedBVBounds diff) + (ValueViewVar stp) + (LinearLoadStoreOffsetDiff stride delta) + +-- | Read from a memory with an array store to the same block we are reading. +-- +-- NOTE: This case should only fire if a write is straddling an array store and +-- another write, as the top-level case of 'readMem' should handle the case +-- where a read is completely covered by a write to an array. +readMemArrayStore + :: forall sym w + . (1 <= w, IsSymInterface sym, HasLLVMAnn sym) + => sym + -> NatRepr w + -> EndianForm + -> MemoryOp sym w + -> LLVMPtr sym w {- ^ The loaded offset -} + -> StorageType {- ^ The type we are reading -} + -> SymBV sym w {- ^ The offset of the mem array store from the base pointer -} + -> SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ The stored array -} + -> Maybe (SymBV sym w) {- ^ The length of the stored array -} + -> (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) + -> ReadMem sym (PartLLVMVal sym) +readMemArrayStore sym w end mop (LLVMPointer blk read_off) tp write_off arr size read_prev = do + let loadFn :: SymBV sym w -> StorageType -> ReadMem sym (PartLLVMVal sym) + loadFn base tp' = liftIO $ do + let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym) + loadArrayByteFn off = do + blk0 <- natLit sym 0 + idx <- bvAdd sym base =<< bvLit sym w (bytesToBV w off) + byte <- arrayLookup sym arr $ Ctx.singleton idx + return $ Partial.totalLLVMVal sym $ LLVMValInt blk0 byte + genValueCtor sym end mop =<< loadTypedValueFromBytes 0 tp' loadArrayByteFn + let varFn = ExprEnv read_off write_off size + case (BV.asUnsigned <$> asBV read_off, BV.asUnsigned <$> asBV write_off) of + -- In this case, both the read and write offsets are concrete + (Just lo, Just so) -> do + let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym) + subFn = \case + OutOfRange o tp' -> do + o' <- liftIO $ bvLit sym w $ bytesToBV w o + read_prev tp' $ LLVMPointer blk o' + InRange o tp' -> do + o' <- liftIO $ bvLit sym w $ bytesToBV w o + loadFn o' tp' + case BV.asUnsigned <$> (asBV =<< size) of + -- The size of the backing SMT array is also concrete, so we can generate a mux-free value + Just concrete_size -> do + let s = R (fromInteger so) (fromInteger (so + concrete_size)) + let vcr = rangeLoad (fromInteger lo) tp s + liftIO . genValueCtor sym end mop =<< traverse subFn vcr + -- Otherwise, the size of the array is unbounded or symbolic + -- + -- The generated mux covers the possible cases where the read straddles + -- the store in various configurations + -- + -- FIXME/Question: Does this properly handle the unbounded array case? Does it + -- need special handling of that case at all? + _ -> evalMuxValueCtor sym w end mop varFn subFn $ + fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so) + -- Otherwise, at least one of the offsets is symbolic (and we will have to generate additional muxes) + _ -> do + let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym) + subFn = \case + OutOfRange o tp' -> do + o' <- liftIO $ genOffsetExpr sym w varFn o + read_prev tp' $ LLVMPointer blk o' + InRange o tp' -> do + o' <- liftIO $ genIntExpr sym w varFn o + -- should always produce a defined value + case o' of + Just o'' -> loadFn o'' tp' + Nothing -> panic "Generic.readMemArrayStore" + [ "Unexpected unbounded size in RangeLoad" + , "*** Integer expression: " ++ show o + , "*** Under environment: " ++ show (ppExprEnv varFn) + ] + let pref + | Just{} <- BV.asUnsigned <$> asBV write_off = FixedStore + | Just{} <- BV.asUnsigned <$> asBV read_off = FixedLoad + | otherwise = NeitherFixed + let rngLd + -- if the size of the data is bounded, use symbolicRangeLoad + | Just _ <- size = symbolicRangeLoad pref tp + -- otherwise, use symbolicUnboundedRangeLoad + | Nothing <- size = symbolicUnboundedRangeLoad pref tp + evalMuxValueCtor sym w end mop varFn subFn rngLd + +readMemInvalidate :: + forall sym w . + ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + sym -> NatRepr w -> + EndianForm -> + MemoryOp sym w -> + LLVMPtr sym w {- ^ The loaded offset -} -> + StorageType {- ^ The type we are reading -} -> + SymBV sym w {- ^ The destination of the invalidation -} -> + Text {- ^ The error message -} -> + SymBV sym w {- ^ The length of the set region -} -> + (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) -> + ReadMem sym (PartLLVMVal sym) +readMemInvalidate sym w end mop (LLVMPointer blk off) tp d msg sz readPrev = + do let ld = BV.asUnsigned <$> asBV off + let dd = BV.asUnsigned <$> asBV d + let varFn = ExprEnv off d (Just sz) + case (ld, dd) of + -- Offset if known + (Just lo, Just so) -> + do let subFn :: RangeLoad Addr Addr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = do + o' <- liftIO $ bvLit sym w (bytesToBV w o) + readPrev tp' (LLVMPointer blk o') + subFn (InRange _o tp') = + readInRange tp' + case BV.asUnsigned <$> asBV sz of + Just csz -> do + let s = R (fromInteger so) (fromInteger (so + csz)) + let vcr = rangeLoad (fromInteger lo) tp s + liftIO . genValueCtor sym end mop =<< traverse subFn vcr + _ -> evalMuxValueCtor sym w end mop varFn subFn $ + fixedOffsetRangeLoad (fromInteger lo) tp (fromInteger so) + -- Symbolic offsets + _ -> + do let subFn :: RangeLoad OffsetExpr IntExpr -> ReadMem sym (PartLLVMVal sym) + subFn (OutOfRange o tp') = do + o' <- liftIO $ genOffsetExpr sym w varFn o + readPrev tp' (LLVMPointer blk o') + subFn (InRange _o tp') = + readInRange tp' + let pref | Just{} <- dd = FixedStore + | Just{} <- ld = FixedLoad + | otherwise = NeitherFixed + let mux0 | Just csz <- BV.asUnsigned <$> asBV sz = + fixedSizeRangeLoad pref tp (fromInteger csz) + | otherwise = + symbolicRangeLoad pref tp + evalMuxValueCtor sym w end mop varFn subFn mux0 + where + readInRange :: StorageType -> ReadMem sym (PartLLVMVal sym) + readInRange tp' + | laxLoadsAndStores ?memOpts && + indeterminateLoadBehavior ?memOpts == UnstableSymbolic + = liftIO (Partial.totalLLVMVal sym <$> freshLLVMVal sym tp') + | otherwise + = liftIO (Partial.partErr sym mop $ Invalidated msg) + +-- | Read a value from memory. +readMem :: forall sym w. + ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + sym -> + NatRepr w -> + Maybe String -> + LLVMPtr sym w -> + StorageType -> + Alignment -> + Mem sym -> + IO (PartLLVMVal sym) +readMem sym w gsym l tp alignment m = do + sz <- bvLit sym w (bytesToBV w (typeEnd 0 tp)) + p1 <- isAllocated sym w alignment l (Just sz) m + p2 <- isAligned sym w l alignment + maybe_allocation_array <- asMemAllocationArrayStore sym w l m + + let mop = MemLoadOp tp gsym l m + + part_val <- case maybe_allocation_array of + -- If this read is inside an allocation backed by a SMT array store, + -- then decompose this read into reading the individual bytes and + -- assembling them to obtain the value, without introducing any + -- ite operations + Just (ok, arr, _arr_sz) | Just True <- asConstantPred ok -> do + let loadArrayByteFn :: Offset -> IO (PartLLVMVal sym) + loadArrayByteFn off = do + blk0 <- natLit sym 0 + idx <- bvAdd sym (llvmPointerOffset l) + =<< bvLit sym w (bytesToBV w off) + byte <- arrayLookup sym arr $ Ctx.singleton idx + return $ Partial.totalLLVMVal sym $ LLVMValInt blk0 byte + genValueCtor sym (memEndianForm m) mop + =<< loadTypedValueFromBytes 0 tp loadArrayByteFn + -- Otherwise, fall back to the less-optimized read case + _ -> readMem' sym w (memEndianForm m) gsym l m tp alignment (memWrites m) + + let stack = getCallStack (m ^. memState) + part_val' <- applyUnless (laxLoadsAndStores ?memOpts) + (Partial.attachSideCondition sym stack p2 (UB.ReadBadAlignment (RV l) alignment)) + part_val + applyUnless (laxLoadsAndStores ?memOpts) + (Partial.attachMemoryError sym p1 mop UnreadableRegion) + part_val' + +data CacheEntry sym w = + CacheEntry !(StorageType) !(SymNat sym) !(SymBV sym w) + +instance (TestEquality (SymExpr sym)) => Eq (CacheEntry sym w) where + (CacheEntry tp1 blk1 off1) == (CacheEntry tp2 blk2 off2) = + tp1 == tp2 && (blk1 == blk2) && (isJust $ testEquality off1 off2) + +instance IsSymInterface sym => Ord (CacheEntry sym w) where + compare (CacheEntry tp1 blk1 off1) (CacheEntry tp2 blk2 off2) = + compare tp1 tp2 + `mappend` compare blk1 blk2 + `mappend` toOrdering (compareF off1 off2) + +toCacheEntry :: StorageType -> LLVMPtr sym w -> CacheEntry sym w +toCacheEntry tp (llvmPointerView -> (blk, bv)) = CacheEntry tp blk bv + + +-- | Read a value from memory given a list of writes. +-- +-- Note that the case where a read is entirely backed by an SMT array store is +-- handled in 'readMem'. +readMem' :: + forall w sym. + ( 1 <= w, IsSymInterface sym, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + sym -> + NatRepr w -> + EndianForm -> + Maybe String -> + LLVMPtr sym w {- ^ Address we are reading -} -> + Mem sym {- ^ The original memory state -} -> + StorageType {- ^ The type to read from memory -} -> + Alignment {- ^ Alignment of pointer to read from -} -> + MemWrites sym {- ^ List of writes -} -> + IO (PartLLVMVal sym) +readMem' sym w end gsym l0 origMem tp0 alignment (MemWrites ws) = + do runReadMem (go fallback0 l0 tp0 [] ws) + where + mop = MemLoadOp tp0 gsym l0 origMem + + fallback0 :: + StorageType -> + LLVMPtr sym w -> + ReadMem sym (PartLLVMVal sym) + fallback0 tp _l = + liftIO $ + if laxLoadsAndStores ?memOpts + && indeterminateLoadBehavior ?memOpts == UnstableSymbolic + then Partial.totalLLVMVal sym <$> freshLLVMVal sym tp + else do -- We're playing a trick here. By making a fresh constant a proof obligation, we can be + -- sure it always fails. But, because it's a variable, it won't be constant-folded away + -- and we can be relatively sure the annotation will survive. + b <- freshConstant sym (safeSymbol "noSatisfyingWrite") BaseBoolRepr + Partial.Err <$> + Partial.annotateME sym mop (NoSatisfyingWrite tp) b + + go :: (StorageType -> LLVMPtr sym w -> ReadMem sym (PartLLVMVal sym)) -> + LLVMPtr sym w -> + StorageType -> + [MemWrite sym] -> + [MemWritesChunk sym] -> + ReadMem sym (PartLLVMVal sym) + go fallback l tp [] [] = fallback tp l + go fallback l tp [] (head_chunk : tail_chunks) = + go fallback l tp (memWritesChunkAt l head_chunk) tail_chunks + go fallback l tp (h : r) rest_chunks = + do cache <- liftIO $ newIORef Map.empty + let readPrev :: + StorageType -> + LLVMPtr sym w -> + ReadMem sym (PartLLVMVal sym) + readPrev tp' l' = do + m <- liftIO $ readIORef cache + case Map.lookup (toCacheEntry tp' l') m of + Just x -> return x + Nothing -> do + x <- go fallback l' tp' r rest_chunks + liftIO $ writeIORef cache $ Map.insert (toCacheEntry tp' l') x m + return x + case h of + WriteMerge _ (MemWrites []) (MemWrites []) -> + go fallback l tp r rest_chunks + WriteMerge c (MemWrites xr) (MemWrites yr) -> + do x <- go readPrev l tp [] xr + y <- go readPrev l tp [] yr + liftIO $ Partial.muxLLVMVal sym c x y + MemWrite dst wsrc -> + case testEquality (ptrWidth dst) w of + Nothing -> readPrev tp l + Just Refl -> + do let LLVMPointer blk1 _ = l + let LLVMPointer blk2 d = dst + let readCurrent = + case wsrc of + MemCopy src sz -> readMemCopy sym w end mop l tp d src sz readPrev + MemSet v sz -> readMemSet sym w end mop l tp d v sz readPrev + MemStore v stp storeAlign -> readMemStore sym w end mop l tp d v stp alignment storeAlign readPrev + MemArrayStore arr sz -> readMemArrayStore sym w end mop l tp d arr sz readPrev + MemInvalidate msg sz -> readMemInvalidate sym w end mop l tp d msg sz readPrev + sameBlock <- liftIO $ natEq sym blk1 blk2 + case asConstantPred sameBlock of + Just True -> do + result <- readCurrent + pure result + Just False -> readPrev tp l + Nothing -> + do x <- readCurrent + y <- readPrev tp l + liftIO $ Partial.muxLLVMVal sym sameBlock x y + +-------------------------------------------------------------------------------- + +-- | Dummy newtype for now... +-- It may be useful later to add additional plumbing +-- to this monad. +newtype ReadMem sym a = ReadMem { runReadMem :: IO a } + deriving (Applicative, Functor, Monad, MonadIO) + + +-------------------------------------------------------------------------------- + +memWritesSize :: MemWrites sym -> Int +memWritesSize (MemWrites writes) = getSum $ foldMap + (\case + MemWritesChunkIndexed indexed_writes -> + foldMap (Sum . length) indexed_writes + MemWritesChunkFlat flat_writes -> Sum $ length flat_writes) + writes + +muxChanges :: IsExpr (SymExpr sym) => Pred sym -> MemChanges sym -> MemChanges sym -> MemChanges sym +muxChanges c (left_allocs, lhs_writes) (rhs_allocs, rhs_writes) = + ( muxMemAllocs c left_allocs rhs_allocs + , muxWrites c lhs_writes rhs_writes + ) + +muxWrites :: IsExpr (SymExpr sym) => Pred sym -> MemWrites sym -> MemWrites sym -> MemWrites sym +muxWrites _ (MemWrites []) (MemWrites []) = MemWrites [] + +muxWrites c lhs_writes rhs_writes + | Just b <- asConstantPred c = if b then lhs_writes else rhs_writes + +muxWrites c lhs_writes rhs_writes + | Just lhs_indexed_writes <- asIndexedChunkMap lhs_writes + , Just rhs_indexed_writes <- asIndexedChunkMap rhs_writes = + MemWrites + [ MemWritesChunkIndexed $ + mergeMemWritesChunkIndexed + (\lhs rhs -> + [ WriteMerge + c + (MemWrites [MemWritesChunkFlat lhs]) + (MemWrites [MemWritesChunkFlat rhs]) + ]) + lhs_indexed_writes + rhs_indexed_writes + ] + | otherwise = + MemWrites [MemWritesChunkFlat [WriteMerge c lhs_writes rhs_writes]] + where asIndexedChunkMap :: MemWrites sym -> Maybe (IntMap [MemWrite sym]) + asIndexedChunkMap (MemWrites [MemWritesChunkIndexed m]) = Just m + asIndexedChunkMap (MemWrites []) = Just IntMap.empty + asIndexedChunkMap _ = Nothing + +mergeMemWritesChunkIndexed :: + ([MemWrite sym] -> [MemWrite sym] -> [MemWrite sym]) -> + IntMap [MemWrite sym] -> + IntMap [MemWrite sym] -> + IntMap [MemWrite sym] +mergeMemWritesChunkIndexed merge_func = IntMap.mergeWithKey + (\_ lhs_alloc_writes rhs_alloc_writes -> Just $ + merge_func lhs_alloc_writes rhs_alloc_writes) + (IntMap.map $ \lhs_alloc_writes -> merge_func lhs_alloc_writes []) + (IntMap.map $ \rhs_alloc_writes -> merge_func [] rhs_alloc_writes) + +memChanges :: Monoid m => (MemChanges sym -> m) -> Mem sym -> m +memChanges f m = go (m^.memState) + where go (EmptyMem _ _ l) = f l + go (StackFrame _ _ _ l s) = f l <> go s + go (BranchFrame _ _ l s) = f l <> go s + +memAllocs :: Mem sym -> MemAllocs sym +memAllocs = memChanges fst + +memWrites :: Mem sym -> MemWrites sym +memWrites = memChanges snd + +memWritesChunkAt :: + IsExprBuilder sym => + LLVMPtr sym w -> + MemWritesChunk sym -> + [MemWrite sym] +memWritesChunkAt ptr = \case + MemWritesChunkIndexed indexed_writes + | Just blk <- asNat (llvmPointerBlock ptr) -> + IntMap.findWithDefault [] (fromIntegral blk) indexed_writes + | otherwise -> IntMap.foldr (++) [] indexed_writes + MemWritesChunkFlat flat_writes -> flat_writes + +memWritesAtConstant :: Natural -> MemWrites sym -> [MemWrite sym] +memWritesAtConstant blk (MemWrites writes) = foldMap + (\case + MemWritesChunkIndexed indexed_writes -> + IntMap.findWithDefault [] (fromIntegral blk) indexed_writes + MemWritesChunkFlat flat_writes -> flat_writes) + writes + +memStateAllocCount :: MemState sym -> Int +memStateAllocCount s = case s of + EmptyMem ac _ _ -> ac + StackFrame ac _ _ _ _ -> ac + BranchFrame ac _ _ _ -> ac + +memStateWriteCount :: MemState sym -> Int +memStateWriteCount s = case s of + EmptyMem _ wc _ -> wc + StackFrame _ wc _ _ _ -> wc + BranchFrame _ wc _ _ -> wc + +memAllocCount :: Mem sym -> Int +memAllocCount m = memStateAllocCount (m ^. memState) + +memWriteCount :: Mem sym -> Int +memWriteCount m = memStateWriteCount (m ^. memState) + +memAddAlloc :: (MemAllocs sym -> MemAllocs sym) -> Mem sym -> Mem sym +memAddAlloc f = memState %~ \case + EmptyMem ac wc (a, w) -> EmptyMem (ac+1) wc (f a, w) + StackFrame ac wc nm (a, w) s -> StackFrame (ac+1) wc nm (f a, w) s + BranchFrame ac wc (a, w) s -> BranchFrame (ac+1) wc (f a, w) s + +memAddWrite :: + (IsExprBuilder sym, 1 <= w) => + LLVMPtr sym w -> + WriteSource sym w -> + Mem sym -> + Mem sym +memAddWrite ptr src = do + let single_write = memWritesSingleton ptr src + memState %~ \case + EmptyMem ac wc (a, w) -> + EmptyMem ac (wc+1) (a, single_write <> w) + StackFrame ac wc nm (a, w) s -> + StackFrame ac (wc+1) nm (a, single_write <> w) s + BranchFrame ac wc (a, w) s -> + BranchFrame ac (wc+1) (a, single_write <> w) s + +memStateAddChanges :: MemChanges sym -> MemState sym -> MemState sym +memStateAddChanges (a, w) = \case + EmptyMem ac wc (a0, w0) -> + EmptyMem (sizeMemAllocs a + ac) (memWritesSize w + wc) (a <> a0, w <> w0) + StackFrame ac wc nm (a0, w0) s -> + StackFrame (sizeMemAllocs a + ac) (memWritesSize w + wc) nm (a <> a0, w <> w0) s + BranchFrame ac wc (a0, w0) s -> + BranchFrame (sizeMemAllocs a + ac) (memWritesSize w + wc) (a <> a0, w <> w0) s + + +-------------------------------------------------------------------------------- +-- Pointer validity + +-- | @isAllocatedMut isMut sym w p sz m@ returns the condition required to +-- prove range @[p..p+sz)@ lies within a single allocation in @m@. +-- +-- This function is parameterized by a predicate on the mutability, so +-- it can optionally be restricted to mutable regions only. +-- It is also parameterized by a required alignment; only allocations +-- with at least this level of alignment are considered. +-- +-- NB this algorithm is set up to explicitly allow both zero size allocations +-- and zero-size chunks to be checked for validity. When 'sz' is 0, every pointer +-- that is inside the range of the allocation OR ONE PAST THE END are considered +-- "allocated"; this is intended, as it captures C's behavior regarding valid +-- pointers. +isAllocatedMut :: + forall sym w . + (1 <= w, IsSymInterface sym) => + (Mutability -> Bool) -> + sym -> NatRepr w -> + Alignment -> + LLVMPtr sym w -> + Maybe (SymBV sym w) -> + Mem sym -> + IO (Pred sym) +isAllocatedMut mutOk sym w minAlign (llvmPointerView -> (blk, off)) sz m = + do (wasAllocated, notFreed) <- isAllocatedGeneric sym inAllocation blk (memAllocs m) + andPred sym wasAllocated notFreed + where + inAllocation :: AllocInfo sym -> IO (Pred sym) + inAllocation (AllocInfo _ asz mut alignment _) + | mutOk mut && alignment >= minAlign = inBounds asz + | otherwise = pure (falsePred sym) + + -- @inBounds a allocatedSz@ produces the predicate that + -- records whether the pointer @ptr@ of size @sz@ falls within the + -- allocation of block @a@ of size @allocatedSz@. + inBounds :: forall w'. Maybe (SymBV sym w') -> IO (Pred sym) + inBounds Nothing = + case sz of + Nothing -> + -- Unbounded access of an unbounded allocation must start at offset 0. + bvEq sym off =<< bvLit sym w (BV.zero w) + Just currSize -> + -- Bounded access of an unbounded allocation requires that + -- @offset + size <= 2^w@, or equivalently @offset <= 2^w - + -- size@. Note that @bvNeg sym size@ computes @2^w - size@ + -- for any nonzero @size@. + do zeroSize <- bvEq sym currSize =<< bvLit sym w (BV.zero w) + noWrap <- bvUle sym off =<< bvNeg sym currSize + orPred sym zeroSize noWrap + + inBounds (Just allocSize) + -- If the allocation is done at pointer width is equal to @w@, check + -- if this allocation covers the required range + | Just Refl <- testEquality w (bvWidth allocSize) + , Just currSize <- sz = + do smallSize <- bvUle sym currSize allocSize -- currSize <= allocSize + maxOffset <- bvSub sym allocSize currSize -- maxOffset = allocSize - currSize + inRange <- bvUle sym off maxOffset -- offset(ptr) <= maxOffset + andPred sym smallSize inRange + + inBounds (Just _allocSize) + -- If the allocation is done at pointer width not equal to @w@, + -- then this is not the allocation we're looking for. Similarly, + -- if @sz@ is @Nothing@ (indicating we are accessing the entire + -- address space) then any bounded allocation is too small. + | otherwise = return $ falsePred sym + +-- | @isAllocated sym w p sz m@ returns the condition required to prove +-- range @[p..p+sz)@ lies within a single allocation in @m@. +-- +-- NB this algorithm is set up to explicitly allow both zero size allocations +-- and zero-size chunks to be checked for validity. When 'sz' is 0, every pointer +-- that is inside the range of the allocation OR ONE PAST THE END are considered +-- "allocated"; this is intended, as it captures C's behavior regarding valid +-- pointers. +isAllocated :: + forall sym w. (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + Alignment -> + LLVMPtr sym w -> + Maybe (SymBV sym w) -> + Mem sym -> + IO (Pred sym) +isAllocated = isAllocatedMut (const True) + +-- | @isAllocatedMutable sym w p sz m@ returns the condition required +-- to prove range @[p..p+sz)@ lies within a single /mutable/ +-- allocation in @m@. +isAllocatedMutable :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym) +isAllocatedMutable = isAllocatedMut (== Mutable) + +-- | Return the condition required to prove that the pointer points to +-- a range of 'size' bytes that falls within an allocated region of +-- the appropriate mutability, and also that the pointer is +-- sufficiently aligned. +isAllocatedAlignedPointer :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + Alignment {- ^ minimum required pointer alignment -} -> + Mutability {- ^ 'Mutable' means pointed-to region must be writable -} -> + LLVMPtr sym w {- ^ pointer -} -> + Maybe (SymBV sym w) {- ^ size (@Nothing@ means entire address space) -} -> + Mem sym {- ^ memory -} -> + IO (Pred sym) +isAllocatedAlignedPointer sym w alignment mutability ptr size mem = + do p1 <- isAllocatedMut mutOk sym w alignment ptr size mem + p2 <- isAligned sym w ptr alignment + andPred sym p1 p2 + where + mutOk m = + case mutability of + Mutable -> m == Mutable + Immutable -> True + +-- | @isValidPointer sym w b m@ returns the condition required to prove that @p@ +-- is a valid pointer in @m@. This means that @p@ is in the range of some +-- allocation OR ONE PAST THE END of an allocation. In other words @p@ is a +-- valid pointer if @b <= p <= b+sz@ for some allocation at base @b@ of size +-- @Just sz@, or if @b <= p@ for some allocation of size @Nothing@. Note that, +-- even though @b+sz@ is outside the allocation range of the allocation +-- (loading through it will fail) it is nonetheless a valid pointer value. +-- This strange special case is baked into the C standard to allow certain +-- common coding patterns to be defined. +isValidPointer :: (1 <= w, IsSymInterface sym) + => sym -> NatRepr w -> LLVMPtr sym w -> Mem sym -> IO (Pred sym) +isValidPointer sym w p m = do + sz <- constOffset sym w 0 + isAllocated sym w noAlignment p (Just sz) m + -- NB We call isAllocated with a size of 0. + +-- | Generate a predicate asserting that the given pointer satisfies +-- the specified alignment constraint. +isAligned :: + forall sym w . + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + LLVMPtr sym w -> + Alignment -> + IO (Pred sym) +isAligned sym _w _p a + | a == noAlignment = return (truePred sym) +isAligned sym w (LLVMPointer _blk offset) a + | Some bits <- mkNatRepr (alignmentToExponent a) + , Just LeqProof <- isPosNat bits + , Just LeqProof <- testLeq bits w = + do lowbits <- bvSelect sym (knownNat :: NatRepr 0) bits offset + bvEq sym lowbits =<< bvLit sym bits (BV.zero bits) +isAligned sym _ _ _ = + return (falsePred sym) + +-- | The LLVM memory model generally does not allow for different +-- memory regions to alias each other: Pointers with different +-- allocation block numbers will compare as definitely unequal. +-- However, it does allow two /immutable/ memory regions to alias each +-- other. To make this sound, equality comparisons between pointers to +-- different immutable memory regions must not evaluate to false. +-- Therefore pointer equality comparisons assert that the pointers are +-- not aliasable: they must not point to two different immutable +-- blocks. +notAliasable :: + forall sym w . + (IsSymInterface sym) => + sym -> + LLVMPtr sym w -> + LLVMPtr sym w -> + Mem sym -> + IO (Pred sym) +notAliasable sym (llvmPointerView -> (blk1, _)) (llvmPointerView -> (blk2, _)) mem = + do p0 <- natEq sym blk1 blk2 + (wasAllocated1, notFreed1) <- isAllocatedGeneric sym isMutable blk1 (memAllocs mem) + (wasAllocated2, notFreed2) <- isAllocatedGeneric sym isMutable blk2 (memAllocs mem) + allocated1 <- andPred sym wasAllocated1 notFreed1 + allocated2 <- andPred sym wasAllocated2 notFreed2 + orPred sym p0 =<< orPred sym allocated1 allocated2 + where + isMutable :: AllocInfo sym -> IO (Pred sym) + isMutable (AllocInfo _ _ Mutable _ _) = pure (truePred sym) + isMutable (AllocInfo _ _ Immutable _ _) = pure (falsePred sym) + +-------------------------------------------------------------------------------- +-- Other memory operations + +-- | Write a value to memory. +-- +-- The returned predicates assert (in this order): +-- * the pointer falls within an allocated, mutable memory region +-- * the pointer's alignment is correct +writeMem :: ( 1 <= w + , IsSymInterface sym + , HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => sym -> NatRepr w + -> Maybe String + -> LLVMPtr sym w + -> StorageType + -> Alignment + -> LLVMVal sym + -> Mem sym + -> IO (Mem sym, Pred sym, Pred sym) +writeMem = writeMemWithAllocationCheck isAllocatedMutable + +-- | Write a value to any memory region, mutable or immutable. +-- +-- The returned predicates assert (in this order): +-- * the pointer falls within an allocated memory region +-- * the pointer's alignment is correct +writeConstMem :: + ( 1 <= w + , IsSymInterface sym + , HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + sym -> + NatRepr w -> + Maybe String -> + LLVMPtr sym w -> + StorageType -> + Alignment -> + LLVMVal sym -> + Mem sym -> + IO (Mem sym, Pred sym, Pred sym) +writeConstMem = writeMemWithAllocationCheck isAllocated + +-- | Write a value to memory. +-- +-- The returned predicates assert (in this order): +-- * the pointer satisfies the checks specified by +-- the @is_allocated@ function +-- * the pointer's alignment is correct +writeMemWithAllocationCheck :: + forall sym w . + ( IsSymInterface sym + , HasLLVMAnn sym + , 1 <= w + , ?memOpts :: MemOptions ) => + (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) -> + sym -> + NatRepr w -> + Maybe String -> + LLVMPtr sym w -> + StorageType -> + Alignment -> + LLVMVal sym -> + Mem sym -> + IO (Mem sym, Pred sym, Pred sym) +writeMemWithAllocationCheck is_allocated sym w gsym ptr tp alignment val mem = do + let mop = MemStoreOp tp gsym ptr mem + let sz = typeEnd 0 tp + sz_bv <- constOffset sym w sz + p1 <- is_allocated sym w alignment ptr (Just sz_bv) mem + p2 <- isAligned sym w ptr alignment + maybe_allocation_array <- asMemAllocationArrayStore sym w ptr mem + mem' <- case maybe_allocation_array of + -- if this write is inside an allocation backed by a SMT array store and + -- the value is not a pointer, then decompose this write into disassembling + -- the value to individual bytes, writing them in the SMT array, and + -- writing the updated SMT array in the memory + Just (ok, arr, arr_sz) | Just True <- asConstantPred ok + , case val of + LLVMValInt block _ -> (asNat block) == (Just 0) + _ -> True -> do + let -- Return @Just value@ if we have successfully loaded a value and + -- should update the corresponding index in the array with that + -- value. Return @Nothing@ otherwise. + subFn :: ValueLoad Addr -> IO (Maybe (PartLLVMVal sym)) + subFn = \case + LastStore val_view -> fmap Just $ applyView + sym + (memEndianForm mem) + mop + (Partial.totalLLVMVal sym val) + val_view + InvalidMemory tp' + | -- With stable-symbolic, loading struct padding is + -- permissible. This is the only case that can return + -- Nothing. + laxLoadsAndStores ?memOpts + , indeterminateLoadBehavior ?memOpts == StableSymbolic + -> pure Nothing + + | otherwise + -> fmap Just $ Partial.partErr sym mop $ Invalid tp' + OldMemory off _ -> panic "Generic.writeMemWithAllocationCheck" + [ "Unexpected offset in storage type" + , "*** Offset: " ++ show off + , "*** StorageType: " ++ show tp + ] + + -- Given a symbolic array and an index into the array, load a byte + -- from the corresponding position in memory and store the byte into + -- the array at that index. + storeArrayByteFn :: + SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) -> + Offset -> + IO (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)) + storeArrayByteFn acc_arr off = do + vc <- traverse subFn (loadBitvector off 1 0 (ValueViewVar tp)) + mb_partial_byte <- traverse (genValueCtor sym (memEndianForm mem) mop) + (sequenceA vc) + + case mb_partial_byte of + Nothing -> + -- If we cannot load the byte from memory, skip updating the + -- array. Currently, the only way that this can arise is when + -- a byte of struct padding is loaded with StableSymbolic + -- enabled. + pure acc_arr + Just partial_byte -> + case partial_byte of + Partial.NoErr _ (LLVMValInt _ byte) + | Just Refl <- testEquality (knownNat @8) (bvWidth byte) -> do + idx <- bvAdd sym (llvmPointerOffset ptr) + =<< bvLit sym w (bytesToBV w off) + arrayUpdate sym acc_arr (Ctx.singleton idx) byte + + Partial.NoErr _ (LLVMValZero _) -> do + byte <- bvLit sym knownRepr (BV.zero knownRepr) + idx <- bvAdd sym (llvmPointerOffset ptr) + =<< bvLit sym w (bytesToBV w off) + arrayUpdate sym acc_arr (Ctx.singleton idx) byte + + Partial.NoErr _ v -> + panic "writeMemWithAllocationCheck" + [ "Expected byte value when updating SMT array, but got:" + , show v + ] + Partial.Err _ -> + panic "writeMemWithAllocationCheck" + [ "Expected succesful byte load when updating SMT array" + , "but got an error instead" + ] + + res_arr <- foldM storeArrayByteFn arr [0 .. (sz - 1)] + overwriteArrayMem sym w ptr res_arr arr_sz mem + + _ -> return $ memAddWrite ptr (MemStore val tp alignment) mem + + return (mem', p1, p2) + +-- | Overwrite SMT array. +-- +-- In this case, we have generated an updated SMT array with all of +-- the changes needed to reflect this memory write. Instead of adding +-- each individual byte write to the write log, we add a single entry that +-- shadows the entire SMT array in memory. This means that the next lookup +-- of e.g., a 4 byte read will see the updated array and be able to read 4 +-- bytes from this array instead of having to traverse the write history +-- to find four different `MemStore`s. +-- +-- Note that the pointer we write to is the *base* pointer (i.e., with +-- offset zero), since we are shadowing the *entire* array. +overwriteArrayMem :: + (1 <= w, IsSymInterface sym) => + sym -> + NatRepr w -> + LLVMPtr sym w -> + SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) -> + SymBV sym w -> + Mem sym -> + IO (Mem sym) +overwriteArrayMem sym w ptr arr sz mem = do + basePtr <- LLVMPointer (llvmPointerBlock ptr) <$> bvLit sym w (BV.mkBV w 0) + return $ memAddWrite basePtr (MemArrayStore arr (Just sz)) mem + +-- | Perform a mem copy (a la @memcpy@ in C). +-- +-- The returned predicates assert (in this order): +-- * the source pointer falls within an allocated memory region +-- * the dest pointer falls within an allocated, mutable memory region +copyMem :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Dest -} -> + LLVMPtr sym w {- ^ Source -} -> + SymBV sym w {- ^ Size -} -> + Mem sym -> IO (Mem sym, Pred sym, Pred sym) +copyMem sym w dst src sz m = + do p1 <- isAllocated sym w noAlignment src (Just sz) m + p2 <- isAllocatedMutable sym w noAlignment dst (Just sz) m + dst_maybe_allocation_array <- asMemAllocationArrayStore sym w dst m + src_maybe_allocation_array <- asMemAllocationArrayStore sym w src m + m' <- case (dst_maybe_allocation_array, src_maybe_allocation_array) of + -- if both the dst and src of this copy operation are inside allocations + -- backed by SMT array stores, then replace this copy operation with + -- using SMT array copy, and writing the result SMT array in the memory + (Just (dst_ok, dst_arr, dst_arr_sz), Just (src_ok, src_arr, _src_arr_sz)) + | Just True <- asConstantPred dst_ok + , Just True <- asConstantPred src_ok -> + do res_arr <- arrayCopy sym dst_arr (llvmPointerOffset dst) src_arr (llvmPointerOffset src) sz + overwriteArrayMem sym w dst res_arr dst_arr_sz m + + _ -> return $ memAddWrite dst (MemCopy src sz) m + + return (m', p1, p2) + +-- | Perform a mem set, filling a number of bytes with a given 8-bit +-- value. The returned 'Pred' asserts that the pointer falls within an +-- allocated, mutable memory region. +setMem :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + SymBV sym 8 {- ^ Byte value -} -> + SymBV sym w {- ^ Number of bytes to set -} -> + Mem sym -> IO (Mem sym, Pred sym) + +setMem sym w ptr val sz m = + do p <- isAllocatedMutable sym w noAlignment ptr (Just sz) m + maybe_allocation_array <- asMemAllocationArrayStore sym w ptr m + m' <- case maybe_allocation_array of + -- if this set operation is inside an allocation backed by a SMT array + -- store, then replace this set operation with using SMT array set, and + -- writing the result SMT array in the memory + Just (ok, arr, arr_sz) | Just True <- asConstantPred ok -> + do res_arr <- arraySet sym arr (llvmPointerOffset ptr) val sz + overwriteArrayMem sym w ptr res_arr arr_sz m + + _ -> return $ memAddWrite ptr (MemSet val sz) m + + return (m', p) + +writeArrayMemWithAllocationCheck :: + (IsSymInterface sym, 1 <= w) => + (sym -> NatRepr w -> Alignment -> LLVMPtr sym w -> Maybe (SymBV sym w) -> Mem sym -> IO (Pred sym)) -> + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + Alignment -> + SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} -> + Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} -> + Mem sym -> IO (Mem sym, Pred sym, Pred sym) +writeArrayMemWithAllocationCheck is_allocated sym w ptr alignment arr sz m = + do p1 <- is_allocated sym w alignment ptr sz m + p2 <- isAligned sym w ptr alignment + let default_m = memAddWrite ptr (MemArrayStore arr sz) m + maybe_allocation_array <- asMemAllocationArrayStore sym w ptr m + m' <- case maybe_allocation_array of + -- if this write is inside an allocation backed by a SMT array store, + -- then replace this copy operation with using SMT array copy, and + -- writing the result SMT array in the memory + Just (ok, alloc_arr, alloc_sz) + | Just True <- asConstantPred ok, Just arr_sz <- sz -> + do sz_diff <- bvSub sym alloc_sz arr_sz + case asBV sz_diff of + Just (BV.BV 0) -> return default_m + _ -> + do zero_off <- bvLit sym w $ BV.mkBV w 0 + res_arr <- arrayCopy sym alloc_arr (llvmPointerOffset ptr) arr zero_off arr_sz + overwriteArrayMem sym w ptr res_arr alloc_sz m + + _ -> return default_m + + return (m', p1, p2) + +-- | Write an array to memory. +-- +-- The returned predicates assert (in this order): +-- * the pointer falls within an allocated, mutable memory region +-- * the pointer has the proper alignment +writeArrayMem :: + (IsSymInterface sym, 1 <= w) => + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + Alignment -> + SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} -> + Maybe (SymBV sym w) {- ^ Array size; if @Nothing@, the size is unrestricted -} -> + Mem sym -> IO (Mem sym, Pred sym, Pred sym) +writeArrayMem = writeArrayMemWithAllocationCheck isAllocatedMutable + +-- | Write an array to memory. +-- +-- The returned predicates assert (in this order): +-- * the pointer falls within an allocated memory region +-- * the pointer has the proper alignment +writeArrayConstMem :: + (IsSymInterface sym, 1 <= w) => + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + Alignment -> + SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8) {- ^ Array value -} -> + Maybe (SymBV sym w) {- ^ Array size -} -> + Mem sym -> IO (Mem sym, Pred sym, Pred sym) +writeArrayConstMem = writeArrayMemWithAllocationCheck isAllocated + +-- | Explicitly invalidate a region of memory. +invalidateMem :: + (1 <= w, IsSymInterface sym) => + sym -> NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + Text {- ^ Message -} -> + SymBV sym w {- ^ Number of bytes to set -} -> + Mem sym -> IO (Mem sym, Pred sym) +invalidateMem sym w ptr msg sz m = + do p <- isAllocatedMutable sym w noAlignment ptr (Just sz) m + return (memAddWrite ptr (MemInvalidate msg sz) m, p) + +-- | Allocate a new empty memory region. +allocMem :: (1 <= w) => + AllocType -- ^ Type of allocation + -> Natural -- ^ Block id for allocation + -> Maybe (SymBV sym w) -- ^ Size + -> Alignment + -> Mutability -- ^ Is block read-only + -> String -- ^ Source location + -> Mem sym + -> Mem sym +allocMem a b sz alignment mut loc = + memAddAlloc (allocMemAllocs b (AllocInfo a sz mut alignment loc)) + +-- | Allocate and initialize a new memory region. +allocAndWriteMem :: + (1 <= w, IsExprBuilder sym) => + sym -> NatRepr w -> + AllocType {- ^ Type of allocation -} -> + Natural {- ^ Block id for allocation -} -> + StorageType -> + Alignment -> + Mutability {- ^ Is block read-only -} -> + String {- ^ Source location -} -> + LLVMVal sym {- ^ Value to write -} -> + Mem sym -> IO (Mem sym) +allocAndWriteMem sym w a b tp alignment mut loc v m = + do sz <- bvLit sym w (bytesToBV w (typeEnd 0 tp)) + base <- natLit sym b + off <- bvLit sym w (BV.zero w) + let p = LLVMPointer base off + return (m & allocMem a b (Just sz) alignment mut loc + & memAddWrite p (MemStore v tp alignment)) + +pushStackFrameMem :: Text -> Mem sym -> Mem sym +pushStackFrameMem nm = memState %~ \s -> + StackFrame (memStateAllocCount s) (memStateWriteCount s) nm emptyChanges s + +popStackFrameMem :: forall sym. Mem sym -> Mem sym +popStackFrameMem m = m & memState %~ popf + where popf :: MemState sym -> MemState sym + popf (StackFrame _ _ _ (a,w) s) = + s & memStateAddChanges c + where c = (popMemAllocs a, w) + + -- WARNING: The following code executes a stack pop underneath a branch + -- frame. This is necessary to get merges to work correctly + -- when they propagate all the way to function returns. + -- However, it is not clear that the following code is + -- precisely correct because it may leave in place writes to + -- memory locations that have just been popped off the stack. + -- This does not appear to be causing problems for our + -- examples, but may be a source of subtle errors. + popf (BranchFrame _ wc (a,w) s) = + BranchFrame (sizeMemAllocs (fst c)) wc c $ popf s + where c = (popMemAllocs a, w) + + popf EmptyMem{} = error "popStackFrameMem given unexpected memory" + + +-- | Free a heap-allocated block of memory. +-- +-- The returned predicates assert (in this order): +-- * the pointer points to the base of a block +-- * said block was heap-allocated, and mutable +-- * said block was not previously freed +-- +-- Because the LLVM memory model allows immutable blocks to alias each other, +-- freeing an immutable block could lead to unsoundness. +freeMem :: forall sym w . + (1 <= w, IsSymInterface sym) => + sym -> + NatRepr w -> + LLVMPtr sym w {- ^ Base of allocation to free -} -> + Mem sym -> + String {- ^ Source location -} -> + IO (Mem sym, Pred sym, Pred sym, Pred sym) +freeMem sym w (LLVMPointer blk off) m loc = + do p1 <- bvEq sym off =<< bvLit sym w (BV.zero w) + (wasAllocated, notFreed) <- isAllocatedGeneric sym isHeapMutable blk (memAllocs m) + return (memAddAlloc (freeMemAllocs blk loc) m, p1, wasAllocated, notFreed) + where + isHeapMutable :: AllocInfo sym -> IO (Pred sym) + isHeapMutable (AllocInfo HeapAlloc _ Mutable _ _) = pure (truePred sym) + isHeapMutable _ = pure (falsePred sym) + +branchMem :: Mem sym -> Mem sym +branchMem = memState %~ \s -> + BranchFrame (memStateAllocCount s) (memStateWriteCount s) emptyChanges s + +branchAbortMem :: Mem sym -> Mem sym +branchAbortMem = memState %~ popf + where popf (BranchFrame _ _ c s) = s & memStateAddChanges c + popf _ = error "branchAbortMem given unexpected memory" + +mergeMem :: IsExpr (SymExpr sym) => Pred sym -> Mem sym -> Mem sym -> Mem sym +mergeMem c x y = + case (x^.memState, y^.memState) of + (BranchFrame _ _ a s, BranchFrame _ _ b _) -> + let s' = s & memStateAddChanges (muxChanges c a b) + in x & memState .~ s' + _ -> error "mergeMem given unexpected memories" + +-------------------------------------------------------------------------------- +-- Finding allocations + +-- When we have a concrete allocation number, we can ask more specific questions +-- to the solver and get (overapproximate) concrete answers. + +data SomeAlloc sym = + forall w. (1 <= w) => SomeAlloc AllocType Natural (Maybe (SymBV sym w)) Mutability Alignment String + +instance IsSymInterface sym => Eq (SomeAlloc sym) where + SomeAlloc x_atp x_base x_sz x_mut x_alignment x_loc == SomeAlloc y_atp y_base y_sz y_mut y_alignment y_loc = do + let sz_eq = case (x_sz, y_sz) of + (Just x_bv, Just y_bv) -> isJust $ testEquality x_bv y_bv + (Nothing, Nothing) -> True + _ -> False + x_atp == y_atp && x_base == y_base && sz_eq && x_mut == y_mut && x_alignment == y_alignment && x_loc == y_loc + +ppSomeAlloc :: forall sym ann. IsExprBuilder sym => SomeAlloc sym -> Doc ann +ppSomeAlloc (SomeAlloc atp base sz mut alignment loc) = + ppAllocInfo (base, AllocInfo atp sz mut alignment loc :: AllocInfo sym) + +-- | Find an overapproximation of the set of allocations with this number. +possibleAllocs :: + forall sym . + (IsSymInterface sym) => + Natural -> + Mem sym -> + [SomeAlloc sym] +possibleAllocs n mem = + case possibleAllocInfo n (memAllocs mem) of + Nothing -> [] + Just (AllocInfo atp sz mut alignment loc) -> + [SomeAlloc atp n sz mut alignment loc] + +-- | Check if @LLVMPtr sym w@ points inside an allocation that is backed +-- by an SMT array store. If true, return a predicate that indicates +-- when the given array backs the given pointer, the SMT array, +-- and the size of the allocation. +-- +-- NOTE: this operation is linear in the size of the list of previous +-- memory writes. This means that memory writes as well as memory reads +-- require a traversal of the list of previous writes. The performance +-- of this operation can be improved by using a map to index the writes +-- by allocation index. +asMemAllocationArrayStore :: + forall sym w . + (IsSymInterface sym, 1 <= w) => + sym -> + NatRepr w -> + LLVMPtr sym w {- ^ Pointer -} -> + Mem sym -> + IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8), (SymBV sym w))) +asMemAllocationArrayStore sym w ptr mem + | Just blk_no <- asNat (llvmPointerBlock ptr) + , [SomeAlloc _ _ (Just sz) _ _ _] <- List.nub (possibleAllocs blk_no mem) + , Just Refl <- testEquality w (bvWidth sz) = + do result <- findArrayStore blk_no sz $ memWritesAtConstant blk_no $ memWrites mem + return $ case result of + Just (ok, arr) -> Just (ok, arr, sz) + Nothing -> Nothing + + | otherwise = return Nothing + + where + findArrayStore :: + Natural -> + SymBV sym w -> + [MemWrite sym] -> + IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))) + + findArrayStore _ _ [] = return Nothing + + findArrayStore blk_no sz (head_mem_write : tail_mem_writes) = + case head_mem_write of + MemWrite write_ptr write_source + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no == write_blk_no + , Just (BV.BV 0) <- asBV (llvmPointerOffset write_ptr) + , MemArrayStore arr (Just arr_store_sz) <- write_source + , Just Refl <- testEquality w (ptrWidth write_ptr) -> do + ok <- bvEq sym sz arr_store_sz + return (Just (ok, arr)) + + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no /= write_blk_no -> + findArrayStore blk_no sz tail_mem_writes + + | otherwise -> return Nothing + + WriteMerge cond lhs_mem_writes rhs_mem_writes -> do + lhs_result <- findArrayStore blk_no sz (memWritesAtConstant blk_no lhs_mem_writes) + rhs_result <- findArrayStore blk_no sz (memWritesAtConstant blk_no rhs_mem_writes) + + -- Only traverse the tail if necessary, and be careful + -- only to traverse it once + case (lhs_result, rhs_result) of + (Just _, Just _) -> combineResults cond lhs_result rhs_result + + (Just _, Nothing) -> + do rhs' <- findArrayStore blk_no sz tail_mem_writes + combineResults cond lhs_result rhs' + + (Nothing, Just _) -> + do lhs' <- findArrayStore blk_no sz tail_mem_writes + combineResults cond lhs' rhs_result + + (Nothing, Nothing) -> findArrayStore blk_no sz tail_mem_writes + + combineResults cond (Just (lhs_ok, lhs_arr)) (Just (rhs_ok, rhs_arr)) = + do ok <- itePred sym cond lhs_ok rhs_ok + arr <- arrayIte sym cond lhs_arr rhs_arr + pure (Just (ok,arr)) + + combineResults cond (Just (lhs_ok, lhs_arr)) Nothing = + do ok <- andPred sym cond lhs_ok + pure (Just (ok, lhs_arr)) + + combineResults cond Nothing (Just (rhs_ok, rhs_arr)) = + do cond' <- notPred sym cond + ok <- andPred sym cond' rhs_ok + pure (Just (ok, rhs_arr)) + + combineResults _cond Nothing Nothing = pure Nothing + +{- Note [Memory Model Design] + +At a high level, the memory model is represented as a list of memory writes +(with embedded muxes). Reads from the memory model are accomplished by +1. Traversing backwards in the write log until the most recent write to each byte + needed to satisfy the read has been covered by a write +2. Re-assembling the read value from fragments of those writes + +This story is slightly complicated by optimizations and the fact that memory +regions can be represented in two different ways: +- "plain" allocations that are represented as symbolic bytes managed explicitly by the memory model, and +- Symbolic array storage backed by SMT arrays + +The former allow for significant optimizations that lead to smaller formulas for +the underlying SMT solver. The latter support symbolic reads efficiently. The +former also supports symbolic reads, at the cost of extremely expensive and +large muxes. + +* Memory Writes + +The entry point for writing values to memory is 'writeMem' (which is just a +wrapper around 'writeMemWithAllocationCheck'). Writing a value to memory is +relatively simple, with only two major cases to consider. + +The first case is an optimization over the SMT array backed memory model. In +this case, the write can be statically determined to be contained entirely +within the bounds of an SMT array. For efficiency, the memory model employs an +optimization that generates an updated SMT array (via applications of the SMT +`update` operator) and adds a special entry in the write log that shadows the +entire address range covered by that array in the write history (effectively +overwriting the entire backing array). The goal of this optimization is to +reduce the number of muxes generated in subsequent reads. + +In the general case, writing to the memory model adds a write record to the +write log. + +* Memory Reads + +The entry point for reading is the 'readMem' function. Reading is more +complicated than writing, as reads can span multiple writes (and also multiple +different allocation types). + +The memory reading code has an optimization to match the 'writeMem' case: if a +read is fully-covered by an SMT array, a fast path is taken that generates small +concrete array select terms. + +In the fallback case, 'readMem' (via 'readMem'') traverses the write log to +assemble a Part(ial)LLVMVal from multiple writes. The code is somewhat CPSed +via the 'readPrev' functions in that code. If the traversal of the write log +finds a write that provides some, but not all, of the bytes covering a read, it +saves those bytes and invokes 'readPrev' to step back through the write log. +See Note [Value Reconstruction] for a description of how bytes from multiple +writes are re-assembled. Note that the write log is a mix of 'MemWrite's and +'WriteMerge's; the explicit merge markers turn the log into a tree, where the +join points create muxes in the read value. + +Note that the partiality in 'Part(ial)LLVMVal's does not refer to fragments of +values. Instead, it refers to the fact that values may be only defined when +some predicate is true. + +* Special Operations + +The memory model has special support for memcpy and memset operations, which are +able to support symbolic lengths. These operations are represented as +distinguished operations in the write log and are incorporated into the results +of reads as appropriate. + +-} + + +{- Note [Value Reconstruction] + +When a value is read, it may span multiple writes in memory (as C/C++/machine +code can do all manner of partial writes into the middle of objects). The +various reading operations thus produce values of type 'ValueCtor' to represent +the reconstruction of values from fragments. The 'ValueCtor' is essentially a +script in a restricted DSL that reconstructs values. The "script" is +interpreted by 'genValueCtor'. + +The reconstruction scripts are produced by the 'valueLoad', 'symbolicValueLoad', +and 'rangeLoad' functions. Note that 'rangeLoad' is used for allocations backed +by SMT arrays, and thus always supports symbolic loads. These functions handle +the complexities of handling padding and data type interpretations. The fast +paths in the read functions are able to call these directly (i.e., when offsets +and sizes are concrete). + +-} diff --git a/src/Lang/Crucible/LLVM/MemModel/MemLog.hs b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs @@ -0,0 +1,746 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.MemLog +-- Description : Data types supporting the LLVM memory model +-- Copyright : (c) Galois, Inc 2011-2020 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# Language ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} + +module Lang.Crucible.LLVM.MemModel.MemLog + ( + -- * Allocation logs + AllocType(..) + , Mutability(..) + , AllocInfo(..) + , MemAllocs(..) + , MemAlloc(..) + , sizeMemAllocs + , allocMemAllocs + , freeMemAllocs + , muxMemAllocs + , popMemAllocs + , possibleAllocInfo + , isAllocatedGeneric + -- * Write logs + , WriteSource(..) + , MemWrite(..) + , MemWrites(..) + , MemWritesChunk(..) + , memWritesSingleton + -- * Memory logs + , MemState(..) + , MemChanges + , memState + , Mem(..) + , emptyChanges + , emptyMem + , memEndian + + -- * Pretty printing + , ppType + , ppPtr + , ppAllocInfo + , ppAllocs + , ppMem + , ppMemWrites + , ppWrite + + -- * Write ranges + , writeRangesMem + + -- * Concretization + , concPtr + , concLLVMVal + , concMem + ) where + +import Control.Applicative ((<|>)) +import Control.Lens +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Foldable +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.List.Extra as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Numeric.Natural +import Prettyprinter + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Ctx (SingleCtx) + +import What4.Interface +import What4.Expr (GroundValue) + +import Lang.Crucible.LLVM.DataLayout (Alignment, fromAlignment, EndianForm(..)) +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemModel.Type +import Lang.Crucible.LLVM.MemModel.Value + +-------------------------------------------------------------------------------- +-- Allocations + +data AllocType = StackAlloc | HeapAlloc | GlobalAlloc + deriving (Eq, Ord, Show) + +data Mutability = Mutable | Immutable + deriving (Eq, Ord, Show) + +-- | Details of a single allocation. The @Maybe SymBV@ argument is either a +-- size or @Nothing@ representing an unbounded allocation. The 'Mutability' +-- indicates whether the region is read-only. The 'String' contains source +-- location information for use in error messages. +data AllocInfo sym = + forall w. (1 <= w) => AllocInfo AllocType (Maybe (SymBV sym w)) Mutability Alignment String + +-- | Stores writeable memory allocations. +data MemAlloc sym + -- | A collection of consecutive basic allocations. + = Allocations (Map Natural (AllocInfo sym)) + -- | Freeing of the given block ID. + | MemFree (SymNat sym) String + -- | The merger of two allocations. + | AllocMerge (Pred sym) (MemAllocs sym) (MemAllocs sym) + +-- | A record of which memory regions have been allocated or freed. + +-- Memory allocations are represented as a list with the invariant +-- that any two adjacent 'Allocations' constructors must be merged +-- together, and that no 'Allocations' constructor has an empty map. +newtype MemAllocs sym = MemAllocs [MemAlloc sym] + +instance Semigroup (MemAllocs sym) where + (MemAllocs lhs_allocs) <> (MemAllocs rhs_allocs) + | Just (lhs_head_allocs, Allocations lhs_m) <- List.unsnoc lhs_allocs + , Allocations rhs_m : rhs_tail_allocs <- rhs_allocs + = MemAllocs (lhs_head_allocs ++ [Allocations (Map.union lhs_m rhs_m)] ++ rhs_tail_allocs) + | otherwise = MemAllocs (lhs_allocs ++ rhs_allocs) + +instance Monoid (MemAllocs sym) where + mempty = MemAllocs [] + + +sizeMemAlloc :: MemAlloc sym -> Int +sizeMemAlloc = + \case + Allocations m -> Map.size m + MemFree{} -> 1 + AllocMerge{} -> 1 + +-- | Compute the size of a 'MemAllocs' log. +sizeMemAllocs :: MemAllocs sym -> Int +sizeMemAllocs (MemAllocs allocs) = sum (map sizeMemAlloc allocs) + +-- | Returns true if this consists of a empty collection of memory allocs. +nullMemAllocs :: MemAllocs sym -> Bool +nullMemAllocs (MemAllocs xs) = null xs + +-- | Allocate a new block with the given allocation ID. +allocMemAllocs :: Natural -> AllocInfo sym -> MemAllocs sym -> MemAllocs sym +allocMemAllocs blk info ma = MemAllocs [Allocations (Map.singleton blk info)] <> ma + +-- | Free the block with the given allocation ID. +freeMemAllocs :: SymNat sym -> String {- ^ Location info for debugging -} -> MemAllocs sym -> MemAllocs sym +freeMemAllocs blk loc (MemAllocs xs) = MemAllocs (MemFree blk loc : xs) + +muxMemAllocs :: IsExpr (SymExpr sym) => Pred sym -> MemAllocs sym -> MemAllocs sym -> MemAllocs sym +muxMemAllocs _ (MemAllocs []) (MemAllocs []) = MemAllocs [] +muxMemAllocs c xs ys = + case asConstantPred c of + Just True -> xs + Just False -> ys + Nothing -> MemAllocs [AllocMerge c xs ys] + +-- | Purge all stack allocations from the allocation log. +popMemAllocs :: forall sym. MemAllocs sym -> MemAllocs sym +popMemAllocs (MemAllocs xs) = MemAllocs (mapMaybe popMemAlloc xs) + where + popMemAlloc :: MemAlloc sym -> Maybe (MemAlloc sym) + popMemAlloc (Allocations am) = + if Map.null am' then Nothing else Just (Allocations am') + where am' = Map.filter notStackAlloc am + popMemAlloc a@(MemFree _ _) = Just a + popMemAlloc (AllocMerge c x y) = Just (AllocMerge c (popMemAllocs x) (popMemAllocs y)) + + notStackAlloc :: AllocInfo sym -> Bool + notStackAlloc (AllocInfo x _ _ _ _) = x /= StackAlloc + +-- | Look up the 'AllocInfo' for the given allocation number. A 'Just' +-- result indicates that the specified memory region may or may not +-- still be allocated; 'Nothing' indicates that the memory region is +-- definitely not allocated. +possibleAllocInfo :: + forall sym. + IsExpr (SymExpr sym) => + Natural -> + MemAllocs sym -> + Maybe (AllocInfo sym) +possibleAllocInfo n (MemAllocs xs) = asum (map helper xs) + where + helper :: MemAlloc sym -> Maybe (AllocInfo sym) + helper = + \case + MemFree _ _ -> Nothing + Allocations m -> Map.lookup n m + AllocMerge cond ma1 ma2 -> + case asConstantPred cond of + Just True -> possibleAllocInfo n ma1 + Just False -> possibleAllocInfo n ma2 + Nothing -> possibleAllocInfo n ma1 <|> possibleAllocInfo n ma2 + + +-- | Generalized function for checking whether a memory region ID is allocated. +-- +-- The first predicate indicates whether the region was allocated, the second +-- indicates whether it has *not* been freed. +isAllocatedGeneric :: + forall sym. + (IsExpr (SymExpr sym), IsExprBuilder sym) => + sym -> + (AllocInfo sym -> IO (Pred sym)) -> + SymNat sym -> + MemAllocs sym -> + IO (Pred sym, Pred sym) +isAllocatedGeneric sym inAlloc blk = go (pure (falsePred sym)) (pure (truePred sym)) + where + go :: IO (Pred sym) -> IO (Pred sym) -> MemAllocs sym -> IO (Pred sym, Pred sym) + go fallback fallbackFreed (MemAllocs []) = (,) <$> fallback <*> fallbackFreed + go fallback fallbackFreed (MemAllocs (alloc : r)) = + case alloc of + Allocations am -> + case asNat blk of + Just b -> -- concrete block number, look up entry + case Map.lookup b am of + Nothing -> go fallback fallbackFreed (MemAllocs r) + Just ba -> (,) <$> inAlloc ba <*> fallbackFreed + Nothing -> -- symbolic block number, need to check all entries + Map.foldrWithKey checkEntry (go fallback fallbackFreed (MemAllocs r)) am + where + checkEntry a ba k = + do + sameBlock <- natEq sym blk =<< natLit sym a + case asConstantPred sameBlock of + Just True -> + -- This is where where this block was allocated, and it + -- couldn't have been freed before it was allocated. + -- + -- NOTE(lb): It's not clear to me that this branch is + -- reachable: If the equality test can succeed + -- concretely, wouldn't asNat have returned a Just + -- above? In either case, this answer should be sound. + return (truePred sym, truePred sym) + Just False -> k + Nothing -> + do (fallback', fallbackFreed') <- k + here <- itePredM sym sameBlock (inAlloc ba) (pure fallback') + pure (here, fallbackFreed') + MemFree a _ -> + do sameBlock <- natEq sym blk a + case asConstantPred sameBlock of + Just True -> + -- If it was freed, it also must have been allocated beforehand. + return (truePred sym, falsePred sym) + Just False -> go fallback fallbackFreed (MemAllocs r) + Nothing -> + do (inRest, notFreedInRest) <- + go fallback fallbackFreed (MemAllocs r) + notSameBlock <- notPred sym sameBlock + (inRest,) <$> andPred sym notSameBlock notFreedInRest + AllocMerge _ (MemAllocs []) (MemAllocs []) -> + go fallback fallbackFreed (MemAllocs r) + AllocMerge c xr yr -> + do (inRest, notFreedInRest) <- go fallback fallbackFreed (MemAllocs r) -- TODO: wrap this in a delay + (inTrue, notFreedInTrue) <- go (pure inRest) (pure notFreedInRest) xr + (inFalse, notFreedInFalse) <- go (pure inRest) (pure notFreedInRest) yr + (,) <$> itePred sym c inTrue inFalse + <*> itePred sym c notFreedInTrue notFreedInFalse + +-------------------------------------------------------------------------------- +-- Writes + +data WriteSource sym w + -- | @MemCopy src len@ copies @len@ bytes from [src..src+len). + = MemCopy (LLVMPtr sym w) (SymBV sym w) + -- | @MemSet val len@ fills the destination with @len@ copies of byte @val@. + | MemSet (SymBV sym 8) (SymBV sym w) + -- | @MemStore val ty al@ writes value @val@ with type @ty@ at the destination. + -- with alignment at least @al@. + | MemStore (LLVMVal sym) StorageType Alignment + -- | @MemArrayStore block (Just len)@ writes byte-array @block@ of size + -- @len@ at the destination; @MemArrayStore block Nothing@ writes byte-array + -- @block@ of unbounded size + | MemArrayStore (SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8)) (Maybe (SymBV sym w)) + -- | @MemInvalidate len@ flags @len@ bytes as uninitialized. + | MemInvalidate Text (SymBV sym w) + +data MemWrite sym + -- | @MemWrite dst src@ represents a write to @dst@ from the given source. + = forall w. (1 <= w) => MemWrite (LLVMPtr sym w) (WriteSource sym w) + -- | The merger of two memories. + | WriteMerge (Pred sym) (MemWrites sym) (MemWrites sym) + + +-------------------------------------------------------------------------------- +-- Memory + +-- | A symbolic representation of the LLVM heap. +-- +-- This representation is designed to support a variety of operations +-- including reads and writes of symbolic data to symbolic addresses, +-- symbolic memcpy and memset, and merging two memories in a single +-- memory using an if-then-else operation. +-- +-- A common use case is that the symbolic simulator will branch into +-- two execution states based on a symbolic branch, make different +-- memory modifications on each branch, and then need to merge the two +-- memories to resume execution along a single path using the branch +-- condition. To support this, our memory representation supports +-- "branch frames", at any point one can insert a fresh branch frame +-- (see `branchMem`), and then at some later point merge two memories +-- back into a single memory (see `mergeMem`). Our `mergeMem` +-- implementation is able to efficiently merge memories, but requires +-- that one only merge memories that were identical prior to the last +-- branch. +data Mem sym = Mem { memEndianForm :: EndianForm, _memState :: MemState sym } + +memState :: Lens' (Mem sym) (MemState sym) +memState = lens _memState (\s v -> s { _memState = v }) + +-- | A state of memory as of a stack push, branch, or merge. Counts +-- of the total number of allocations and writes are kept for +-- performance metrics. +data MemState sym = + -- | Represents initial memory and changes since then. + -- Changes are stored in order, with more recent changes closer to the head + -- of the list. + EmptyMem !Int !Int (MemChanges sym) + -- | Represents a push of a stack frame, and changes since that stack push. + -- The text value gives a user-consumable name for the stack frame. + -- Changes are stored in order, with more recent changes closer to the head + -- of the list. + | StackFrame !Int !Int Text (MemChanges sym) (MemState sym) + -- | Represents a push of a branch frame, and changes since that branch. + -- Changes are stored in order, with more recent changes closer to the head + -- of the list. + | BranchFrame !Int !Int (MemChanges sym) (MemState sym) + +type MemChanges sym = (MemAllocs sym, MemWrites sym) + +-- | Memory writes are represented as a list of chunks of writes. +-- Chunks alternate between being indexed and being flat. +newtype MemWrites sym = MemWrites [MemWritesChunk sym] + +-- | Returns true if this consists of a empty collection of memory writes +nullMemWrites :: MemWrites sym -> Bool +nullMemWrites (MemWrites ws) = null ws + +-- | A chunk of memory writes is either indexed or flat (unindexed). +-- An indexed chunk consists of writes to addresses with concrete +-- base pointers and is represented as a map. A flat chunk consists of +-- writes to addresses with symbolic base pointers. A merge of two +-- indexed chunks is a indexed chunk, while any other merge is part of +-- a flat chunk. +data MemWritesChunk sym = + MemWritesChunkFlat [MemWrite sym] + | MemWritesChunkIndexed (IntMap [MemWrite sym]) + +instance Semigroup (MemWrites sym) where + (MemWrites lhs_writes) <> (MemWrites rhs_writes) + | Just (lhs_head_writes, lhs_tail_write) <- List.unsnoc lhs_writes + , MemWritesChunkIndexed lhs_tail_indexed_writes <- lhs_tail_write + , rhs_head_write : rhs_tail_writes <- rhs_writes + , (MemWritesChunkIndexed rhs_head_indexed_writes) <- rhs_head_write = do + let merged_chunk = MemWritesChunkIndexed $ IntMap.mergeWithKey + (\_ lhs_alloc_writes rhs_alloc_writes -> + Just $ lhs_alloc_writes ++ rhs_alloc_writes) + id + id + lhs_tail_indexed_writes + rhs_head_indexed_writes + MemWrites $ lhs_head_writes ++ [merged_chunk] ++ rhs_tail_writes + | otherwise = MemWrites $ lhs_writes ++ rhs_writes + +instance Monoid (MemWrites sym) where + mempty = MemWrites [] + + +memWritesSingleton :: + (IsExprBuilder sym, 1 <= w) => + LLVMPtr sym w -> + WriteSource sym w -> + MemWrites sym +memWritesSingleton ptr src + | Just blk <- asNat (llvmPointerBlock ptr) + , isIndexableSource src = + MemWrites + [ MemWritesChunkIndexed $ + IntMap.singleton (fromIntegral blk) [MemWrite ptr src] + ] + | otherwise = MemWrites [MemWritesChunkFlat [MemWrite ptr src]] + where + isIndexableSource :: WriteSource sym w -> Bool + isIndexableSource = \case + MemStore{} -> True + MemArrayStore{} -> True + MemSet{} -> True + MemInvalidate{} -> True + MemCopy{} -> False + + + +emptyChanges :: MemChanges sym +emptyChanges = (mempty, mempty) + +emptyMem :: EndianForm -> Mem sym +emptyMem e = Mem { memEndianForm = e, _memState = EmptyMem 0 0 emptyChanges } + +memEndian :: Mem sym -> EndianForm +memEndian = memEndianForm + + +-------------------------------------------------------------------------------- +-- Pretty printing + +ppMerge :: IsExpr e + => (v -> Doc ann) + -> e tp + -> [v] + -> [v] + -> Doc ann +ppMerge vpp c x y = + indent 2 $ + vcat + [ "Condition:" + , indent 2 (printSymExpr c) + , ppAllocList x "True Branch:" + , ppAllocList y "False Branch:" + ] + where ppAllocList [] d = d <+> "" + ppAllocList xs d = vcat [d, indent 2 (vcat $ map vpp xs)] + +ppAlignment :: Alignment -> Doc ann +ppAlignment a = + pretty $ show (fromAlignment a) ++ "-byte-aligned" + +ppAllocInfo :: IsExpr (SymExpr sym) => (Natural, AllocInfo sym) -> Doc ann +ppAllocInfo (base, AllocInfo atp sz mut alignment loc) = + viaShow atp + <+> pretty base + <+> maybe mempty printSymExpr sz + <+> viaShow mut + <+> ppAlignment alignment + <+> pretty loc + +ppAlloc :: IsExpr (SymExpr sym) => MemAlloc sym -> Doc ann +ppAlloc (Allocations xs) = + vcat $ map ppAllocInfo (reverse (Map.assocs xs)) +ppAlloc (MemFree base loc) = + "Free" <+> printSymNat base <+> pretty loc +ppAlloc (AllocMerge c (MemAllocs x) (MemAllocs y)) = + vcat ["Merge", ppMerge ppAlloc c x y] + +ppAllocs :: IsExpr (SymExpr sym) => MemAllocs sym -> Doc ann +ppAllocs (MemAllocs xs) = vcat $ map ppAlloc xs + +ppWrite :: IsExpr (SymExpr sym) => MemWrite sym -> Doc ann +ppWrite (MemWrite d (MemCopy s l)) = do + "memcopy" <+> ppPtr d <+> ppPtr s <+> printSymExpr l +ppWrite (MemWrite d (MemSet v l)) = do + "memset" <+> ppPtr d <+> printSymExpr v <+> printSymExpr l +ppWrite (MemWrite d (MemStore v _ _)) = do + pretty '*' <> ppPtr d <+> ":=" <+> ppTermExpr v +ppWrite (MemWrite d (MemArrayStore arr _)) = do + pretty '*' <> ppPtr d <+> ":=" <+> printSymExpr arr +ppWrite (MemWrite d (MemInvalidate msg l)) = do + "invalidate" <+> parens (pretty msg) <+> ppPtr d <+> printSymExpr l +ppWrite (WriteMerge c (MemWrites x) (MemWrites y)) = do + vcat ["merge", ppMerge ppMemWritesChunk c x y] + +ppMemWritesChunk :: IsExpr (SymExpr sym) => MemWritesChunk sym -> Doc ann +ppMemWritesChunk = \case + MemWritesChunkFlat [] -> + "No writes" + MemWritesChunkFlat flat_writes -> + vcat $ map ppWrite flat_writes + MemWritesChunkIndexed indexed_writes -> + vcat + [ "Indexed chunk:" + , indent 2 (vcat $ map + (\(blk, blk_writes) -> + case blk_writes of + [] -> mempty + _ -> viaShow blk <+> "|->" <> softline <> + indent 2 (vcat $ map ppWrite blk_writes)) + (IntMap.toList indexed_writes)) + ] + +ppMemWrites :: IsExpr (SymExpr sym) => MemWrites sym -> Doc ann +ppMemWrites (MemWrites ws) = vcat $ map ppMemWritesChunk ws + +ppMemChanges :: IsExpr (SymExpr sym) => MemChanges sym -> [Doc ann] +ppMemChanges (al,wl) + | nullMemAllocs al && nullMemWrites wl = ["No writes or allocations"] + | otherwise = + (if nullMemAllocs al then [] else ["Allocations:", indent 2 (ppAllocs al)]) <> + (if nullMemWrites wl then [] else ["Writes:", indent 2 (ppMemWrites wl)]) + +ppMemState :: (MemChanges sym -> [Doc ann]) -> MemState sym -> Doc ann +ppMemState f (EmptyMem _ _ d) = + vcat ("Base memory" : map (indent 2) (f d)) +ppMemState f (StackFrame _ _ nm d ms) = + vcat (("Stack frame" <+> pretty nm) : map (indent 2) (f d) ++ [ppMemState f ms]) +ppMemState f (BranchFrame _ _ d ms) = + vcat ("Branch frame" : map (indent 2) (f d) ++ [ppMemState f ms]) + +ppMem :: IsExpr (SymExpr sym) => Mem sym -> Doc ann +ppMem m = ppMemState ppMemChanges (m^.memState) + + +------------------------------------------------------------------------------ +-- Write ranges + +multiUnion :: (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a +multiUnion = Map.unionWith (<>) + +writeSourceSize :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + WriteSource sym w -> + MaybeT IO (SymBV sym w) +writeSourceSize sym = \case + MemCopy _src sz -> pure sz + MemSet _val sz -> pure sz + MemStore _val st _align -> + liftIO $ bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth $ toInteger $ typeEnd 0 st + MemArrayStore _arr Nothing -> MaybeT $ pure Nothing + MemArrayStore _arr (Just sz) -> pure sz + MemInvalidate _nm sz -> pure sz + +writeRangesMemWrite :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + MemWrite sym -> + MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)]) +writeRangesMemWrite sym = \case + MemWrite ptr wsrc + | Just Refl <- testEquality ?ptrWidth (ptrWidth ptr) -> + case asNat (llvmPointerBlock ptr) of + Just blk -> do + sz <- writeSourceSize sym wsrc + pure $ Map.singleton blk [(llvmPointerOffset ptr, sz)] + Nothing -> MaybeT $ pure Nothing + | otherwise -> fail "foo" + WriteMerge _p ws1 ws2 -> + multiUnion <$> writeRangesMemWrites sym ws1 <*> writeRangesMemWrites sym ws2 + +writeRangesMemWritesChunk :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + MemWritesChunk sym -> + MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)]) +writeRangesMemWritesChunk sym = \case + MemWritesChunkFlat ws -> foldl multiUnion Map.empty <$> mapM (writeRangesMemWrite sym) ws + MemWritesChunkIndexed mp -> + foldl multiUnion Map.empty <$> mapM (writeRangesMemWrite sym) (concat $ IntMap.elems mp) + +writeRangesMemWrites :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + MemWrites sym -> + MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)]) +writeRangesMemWrites sym (MemWrites ws) = + foldl multiUnion Map.empty <$> mapM (writeRangesMemWritesChunk sym) ws + +writeRangesMemChanges :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + MemChanges sym -> + MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)]) +writeRangesMemChanges sym (_as, ws) = writeRangesMemWrites sym ws + +writeRangesMemState :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + MemState sym -> + MaybeT IO (Map Natural [(SymBV sym w, SymBV sym w)]) +writeRangesMemState sym = \case + EmptyMem _a _w chs -> writeRangesMemChanges sym chs + StackFrame _a _w _nm chs st -> + multiUnion <$> writeRangesMemChanges sym chs <*> writeRangesMemState sym st + BranchFrame _a _w chs st -> + multiUnion <$> writeRangesMemChanges sym chs <*> writeRangesMemState sym st + +-- | Compute the ranges (pairs of the form pointer offset and size) for all +-- memory writes, indexed by the pointer base. The result is Nothing if the +-- memory contains any writes with symbolic pointer base, or without size. +writeRangesMem :: + (IsExprBuilder sym, HasPtrWidth w) => + sym -> + Mem sym -> + MaybeT IO ((Map Natural [(SymBV sym w, SymBV sym w)])) +writeRangesMem sym mem = writeRangesMemState sym $ mem ^. memState + + +------------------------------------------------------------------------------ +-- Concretization + +concAllocInfo :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + AllocInfo sym -> IO (AllocInfo sym) +concAllocInfo sym conc (AllocInfo atp sz m a nm) = + do sz' <- traverse (concBV sym conc) sz + pure (AllocInfo atp sz' m a nm) + +concAlloc :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemAlloc sym -> IO (MemAllocs sym) +concAlloc sym conc (Allocations m) = + do m' <- traverse (concAllocInfo sym conc) m + pure (MemAllocs [Allocations m']) +concAlloc sym conc (MemFree blk loc) = + do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk + pure (MemAllocs [MemFree blk' loc]) +concAlloc sym conc (AllocMerge p m1 m2) = + do b <- conc p + if b then concMemAllocs sym conc m1 + else concMemAllocs sym conc m2 + +concMemAllocs :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemAllocs sym -> IO (MemAllocs sym) +concMemAllocs sym conc (MemAllocs cs) = + fold <$> traverse (concAlloc sym conc) cs + +concLLVMVal :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + LLVMVal sym -> IO (LLVMVal sym) +concLLVMVal sym conc (LLVMValInt blk off) = + do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk + off' <- concBV sym conc off + pure (LLVMValInt blk' off') +concLLVMVal _sym _conc (LLVMValFloat fs fi) = + pure (LLVMValFloat fs fi) -- TODO concreteize floats +concLLVMVal sym conc (LLVMValStruct fs) = + LLVMValStruct <$> traverse (\ (fi,v) -> (,) <$> pure fi <*> concLLVMVal sym conc v) fs +concLLVMVal sym conc (LLVMValArray st vs) = + LLVMValArray st <$> traverse (concLLVMVal sym conc) vs +concLLVMVal _ _ v@LLVMValString{} = pure v +concLLVMVal _ _ v@LLVMValZero{} = pure v +concLLVMVal _ _ (LLVMValUndef st) = + pure (LLVMValZero st) -- ??? does it make sense to turn Undef into Zero? + + +concWriteSource :: + (IsExprBuilder sym, 1 <= w) => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + WriteSource sym w -> IO (WriteSource sym w) +concWriteSource sym conc (MemCopy src len) = + MemCopy <$> (concPtr sym conc src) <*> (concBV sym conc len) +concWriteSource sym conc (MemSet val len) = + MemSet <$> (concBV sym conc val) <*> (concBV sym conc len) +concWriteSource sym conc (MemStore val st a) = + MemStore <$> concLLVMVal sym conc val <*> pure st <*> pure a + +concWriteSource _sym _conc (MemArrayStore arr Nothing) = + -- TODO, concretize the actual array + pure (MemArrayStore arr Nothing) +concWriteSource sym conc (MemArrayStore arr (Just sz)) = + -- TODO, concretize the actual array + MemArrayStore arr . Just <$> concBV sym conc sz + +concWriteSource sym conc (MemInvalidate nm len) = + MemInvalidate nm <$> concBV sym conc len + +concMemWrite :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemWrite sym -> IO (MemWrites sym) +concMemWrite sym conc (MemWrite ptr wsrc) = + do ptr' <- concPtr sym conc ptr + wsrc' <- concWriteSource sym conc wsrc + pure $ memWritesSingleton ptr' wsrc' +concMemWrite sym conc (WriteMerge p m1 m2) = + do b <- conc p + if b then concMemWrites sym conc m1 + else concMemWrites sym conc m2 + +concMemWrites :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemWrites sym -> IO (MemWrites sym) +concMemWrites sym conc (MemWrites cs) = + fold <$> mapM (concMemWritesChunk sym conc) cs + +concMemWritesChunk :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemWritesChunk sym -> IO (MemWrites sym) +concMemWritesChunk sym conc (MemWritesChunkFlat ws) = + fold <$> mapM (concMemWrite sym conc) ws +concMemWritesChunk sym conc (MemWritesChunkIndexed mp) = + fold <$> mapM (concMemWrite sym conc) (concat (IntMap.elems mp)) + +concMemChanges :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemChanges sym -> IO (MemChanges sym) +concMemChanges sym conc (as, ws) = + (,) <$> concMemAllocs sym conc as <*> concMemWrites sym conc ws + + +concMemState :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + MemState sym -> IO (MemState sym) +concMemState sym conc (EmptyMem a w chs) = + EmptyMem a w <$> concMemChanges sym conc chs +concMemState sym conc (StackFrame a w nm frm stk) = + StackFrame a w nm <$> concMemChanges sym conc frm <*> concMemState sym conc stk +concMemState sym conc (BranchFrame a w frm stk) = + BranchFrame a w <$> concMemChanges sym conc frm <*> concMemState sym conc stk + +concMem :: + IsExprBuilder sym => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + Mem sym -> IO (Mem sym) +concMem sym conc (Mem endian st) = + Mem endian <$> concMemState sym conc st diff --git a/src/Lang/Crucible/LLVM/MemModel/Options.hs b/src/Lang/Crucible/LLVM/MemModel/Options.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Options.hs @@ -0,0 +1,128 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Options +-- Description : Definition of options that can be tweaked in the memory model +-- Copyright : (c) Galois, Inc 2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +module Lang.Crucible.LLVM.MemModel.Options + ( MemOptions(..) + , IndeterminateLoadBehavior(..) + , defaultMemOptions + , laxPointerMemOptions + ) where + +-- | This datatype encodes a variety of tweakable settings supported +-- by the LLVM memory model. They generally involve some weakening +-- of the strict rules of the language standard to allow common +-- idioms, at the cost that reasoning using the resulting memory model +-- is less generalizable (i.e., makes more assumptions about the +-- runtime behavior of the system). +data MemOptions + = MemOptions + { laxPointerOrdering :: !Bool + -- ^ Should we allow ordering comparisons on pointers that are + -- not from the same allocation unit? This is not allowed + -- by the C standard, but is nonetheless commonly done. + + , laxConstantEquality :: !Bool + -- ^ Should we allow equality comparisons on pointers to constant + -- data? Different symbols with the same data are allowed to + -- be consolidated, so pointer apparently-distinct pointers + -- will sometimes compare equal if the compiler decides to + -- consolidate their storage. + + , laxLoadsAndStores :: !Bool + -- ^ Should we relax some of Crucible's validity checks for memory loads + -- and stores? If 'True', the following checks will be relaxed: + -- + -- * Reading from previously unwritten memory will succeed rather than + -- throwing a 'NoSatisfyingWrite' error. The semantics of what it + -- means to read from uninitialized memory is controlled separately + -- by the 'indeterminateLoadBehavior' option. + -- + -- * If reading from a region that isn't allocated or isn't large + -- enough, Crucible will proceed rather than throw an + -- 'UnreadableRegion' error. + -- + -- * Reading a value from a pointer with insufficent alignment is not + -- treated as undefined behavior. That is, Crucible will not throw a + -- 'ReadBadAlignment' error. + -- + -- * Adding an offset to a pointer that results in a pointer to an + -- address outside of the allocation is not treated as undefined + -- behavior. That is, Crucible will not throw a + -- 'PtrAddOffsetOutOfBounds' error. + -- + -- This option is primarily useful for SV-COMP, which does not treat + -- the scenarios listed above as fatal errors. + + , indeterminateLoadBehavior :: IndeterminateLoadBehavior + -- ^ If 'laxLoadsAndStores' is enabled, what should be the semantics of + -- reading from uninitialized memory? See the Haddocks for + -- 'IndeterminateLoadBehavior' for an explanation of each possible + -- semantics. + -- + -- If 'laxLoadsAndStores' is disabled, this option has no effect. + } + + +-- | What should be the semantics of reading from previously uninitialized +-- memory? +data IndeterminateLoadBehavior + = StableSymbolic + -- ^ After allocating memory (be it through @alloca@, @malloc@, @calloc@, + -- or a similar function), initialize it with a fresh symbolic value of + -- the corresponding type. As a result, reading from \"uninitialized\" + -- memory will always succeed, as uninitialized memory will contain + -- symbolic data if it has not yet been written to. This is \"stable\" + -- in the sense that reading from the same section of uninitialized + -- memory multiple times will always yield the same symbolic value. + -- + -- This is primarily useful for SV-COMP, as these semantics closely align + -- with SV-COMP's expectations. + + | UnstableSymbolic + -- ^ Each read from a section of uninitialized memory will return a fresh + -- symbolic value of the corresponding type. The operative word is + -- \"fresh\", as each of these symbolic values will be considered + -- distinct. That is, the symbolic values are \"unstable\". Contrast this + -- with 'StableSymbolic', in which multiple reads from the same section + -- of uninitialized memory will all yield the same symbolic value. + -- + -- One consequence of the 'UnstableSymbolic' approach is that any + -- pointer can be derefenced, even if it does not actually point to + -- anything. Dereferencing such a pointer will simply yield a fresh + -- symbolic value. On the other hand, dereferencing such a pointer + -- continues to be a Crucible error in 'StableSymbolic'. + deriving (Eq, Show) + +-- | The default memory model options: +-- +-- * Require strict adherence to the language standard regarding pointer +-- equality and ordering. +-- +-- * Perform Crucible's default validity checks for memory loads and stores. +defaultMemOptions :: MemOptions +defaultMemOptions = + MemOptions + { laxPointerOrdering = False + , laxConstantEquality = False + , laxLoadsAndStores = False + -- The choice of StableSymbolic here doesn't matter too much, since it + -- won't have any effect when laxLoadsAndStores is disabled. + , indeterminateLoadBehavior = StableSymbolic + } + + +-- | Like 'defaultMemOptions', but allow pointer ordering comparisons +-- and equality comparisons of pointers to constant data. +laxPointerMemOptions :: MemOptions +laxPointerMemOptions = + defaultMemOptions + { laxPointerOrdering = True + , laxConstantEquality = True + } diff --git a/src/Lang/Crucible/LLVM/MemModel/Partial.hs b/src/Lang/Crucible/LLVM/MemModel/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Partial.hs @@ -0,0 +1,999 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Partial +-- Description : Operations on partial values in the LLVM memory model +-- Copyright : (c) Galois, Inc 2015-2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +------------------------------------------------------------------------ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.MemModel.Partial + ( PartLLVMVal(..) + , partErr + , attachSideCondition + , attachMemoryError + , assertSafe + , MemoryError(..) + , totalLLVMVal + , bvConcat + , consArray + , appendArray + , mkArray + , mkStruct + , HasLLVMAnn + , LLVMAnnMap + , BoolAnn(..) + , annotateME + , annotateUB + , projectLLVM_bv + + , floatToBV + , doubleToBV + , fp80ToBV + , bvToDouble + , bvToFloat + , bvToX86_FP80 + , selectHighBv + , selectLowBv + , arrayElt + , fieldVal + , muxLLVMVal + + , CexExplanation(..) + , explainCex + ) where + +import Prelude hiding (pred) + +import Control.Lens ((^.), view) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Except (ExceptT, MonadError(..), runExceptT) +import Control.Monad.State.Strict (StateT, get, put, runStateT) +import qualified Data.ByteString as BS +import qualified Data.Foldable as Fold +import Data.Maybe (isJust) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes (toOrdering, OrdF(..)) +import Data.Parameterized.NatRepr +import Data.Parameterized.Some (Some(..)) + +import Lang.Crucible.Backend +import Lang.Crucible.Simulator.SimError +import Lang.Crucible.Simulator.RegValue (RegValue'(..)) +import Lang.Crucible.LLVM.Bytes (Bytes) +import qualified Lang.Crucible.LLVM.Bytes as Bytes +import Lang.Crucible.LLVM.MemModel.MemLog (memState) +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack, getCallStack) +import Lang.Crucible.LLVM.MemModel.Pointer ( pattern LLVMPointer, LLVMPtr ) +import Lang.Crucible.LLVM.MemModel.Type (StorageType(..), StorageTypeF(..), Field(..)) +import qualified Lang.Crucible.LLVM.MemModel.Type as Type +import Lang.Crucible.LLVM.MemModel.Value (LLVMVal(..)) +import qualified Lang.Crucible.LLVM.MemModel.Value as Value +import Lang.Crucible.LLVM.Errors +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.Errors.MemoryError (MemoryError(..), MemoryErrorReason(..), MemoryOp(..), memOpMem) +import Lang.Crucible.Panic (panic) + +import What4.Expr +import What4.Expr.BoolMap +import What4.Expr.Builder +import What4.Interface hiding (bvConcat, mkStruct, floatToBV, bvToFloat) +import qualified What4.Interface as W4I +import qualified What4.InterpretedFloatingPoint as W4IFP + + +newtype BoolAnn sym = BoolAnn (SymAnnotation sym BaseBoolType) + +instance IsSymInterface sym => Eq (BoolAnn sym) where + BoolAnn x == BoolAnn y = isJust (testEquality x y) +instance IsSymInterface sym => Ord (BoolAnn sym) where + compare (BoolAnn x) (BoolAnn y) = toOrdering $ compareF x y + +type LLVMAnnMap sym = Map (BoolAnn sym) (CallStack, BadBehavior sym) +type HasLLVMAnn sym = (?recordLLVMAnnotation :: CallStack -> BoolAnn sym -> BadBehavior sym -> IO ()) + +data CexExplanation sym (tp :: BaseType) where + NoExplanation :: CexExplanation sym tp + DisjOfFailures :: [ (CallStack, BadBehavior sym) ] -> CexExplanation sym BaseBoolType + +instance Semigroup (CexExplanation sym BaseBoolType) where + NoExplanation <> y = y + x <> NoExplanation = x + DisjOfFailures xs <> DisjOfFailures ys = DisjOfFailures (xs ++ ys) + +explainCex :: forall t st fs sym. + (IsSymInterface sym, sym ~ ExprBuilder t st fs) => + sym -> + LLVMAnnMap sym -> + Maybe (GroundEvalFn t) -> + IO (Pred sym -> IO (CexExplanation sym BaseBoolType)) +explainCex sym bbMap evalFn = + do posCache <- newIdxCache + negCache <- newIdxCache + pure (evalPos posCache negCache) + + where + evalPos, evalNeg :: + IdxCache t (CexExplanation sym) -> + IdxCache t (CexExplanation sym) -> + Expr t BaseBoolType -> + IO (CexExplanation sym BaseBoolType) + + evalPos posCache negCache e = idxCacheEval posCache e $ + case e of + (asNonceApp -> Just (Annotation BaseBoolRepr annId e')) -> + case Map.lookup (BoolAnn annId) bbMap of + Nothing -> evalPos posCache negCache e' + Just (callStack, bb) -> + do bb' <- case evalFn of + Just f -> concBadBehavior sym (groundEval f) bb + Nothing -> pure bb + pure (DisjOfFailures [ (callStack, bb') ]) + + (asApp -> Just (BaseIte BaseBoolRepr _ c x y)) + | Just f <- evalFn -> + do c' <- groundEval f c + if c' then + evalPos posCache negCache x + else + evalPos posCache negCache y + | otherwise -> + (<>) <$> evalPos posCache negCache x <*> evalPos posCache negCache y + + (asApp -> Just (NotPred e')) -> evalNeg posCache negCache e' + + -- We expect at least one of the contained predicates to be false, so choose one + -- and explain that failure + (asApp -> Just (ConjPred (viewBoolMap -> BoolMapTerms tms))) -> go (Fold.toList tms) + where + go [] = pure NoExplanation + go ((x,Positive):xs) + | Just f <- evalFn = + do x' <- groundEval f x + if x' then + go xs + else + evalPos posCache negCache x >>= \case + NoExplanation -> go xs + ex -> pure ex + | otherwise = + -- no counterexample in hand, assume this might be the problem + evalPos posCache negCache x >>= \case + NoExplanation -> go xs + ex -> pure ex + + go ((x,Negative):xs) + | Just f <- evalFn = + do x' <- groundEval f x + if x' then + evalNeg posCache negCache x >>= \case + NoExplanation -> go xs + ex -> pure ex + else + go xs + | otherwise = + -- no counterexample in hand, assume this might be the problem + evalNeg posCache negCache x >>= \case + NoExplanation -> go xs + ex -> pure ex + + _ -> pure NoExplanation + + evalNeg posCache negCache e = idxCacheEval negCache e $ + case e of + (asApp -> Just (BaseIte BaseBoolRepr _ c x y)) + | Just f <- evalFn -> + do c' <- groundEval f c + if c' then + evalNeg posCache negCache x + else + evalNeg posCache negCache y + | otherwise -> + (<>) <$> evalNeg posCache negCache x <*> evalNeg posCache negCache y + + (asApp -> Just (NotPred e')) -> evalPos posCache negCache e' + + -- under negative polarity, we expect all members of the disjunction to be false, + -- and we must construct an explanation for all of them + (asApp -> Just (ConjPred (viewBoolMap -> BoolMapTerms tms))) -> go (Fold.toList tms) NoExplanation + where + go [] es = pure es + go ((x,Positive):xs) es = + do ex <- evalNeg posCache negCache x + go xs (ex <> es) + go ((x,Negative):xs) es = + do ex <- evalPos posCache negCache x + go xs (ex <> es) + + _ -> pure NoExplanation + +annotateUB :: (IsSymInterface sym, HasLLVMAnn sym) => + sym -> + CallStack -> + UB.UndefinedBehavior (RegValue' sym) -> + Pred sym -> + IO (Pred sym) +annotateUB sym callStack ub p = + do (n, p') <- annotateTerm sym p + ?recordLLVMAnnotation callStack (BoolAnn n) (BBUndefinedBehavior ub) + return p' + +memOpCallStack :: MemoryOp sym w -> CallStack +memOpCallStack = getCallStack . view memState . memOpMem + +annotateME :: (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + MemoryErrorReason -> + Pred sym -> + IO (Pred sym) +annotateME sym mop rsn p = + do (n, p') <- annotateTerm sym p + ?recordLLVMAnnotation + (memOpCallStack mop) + (BoolAnn n) + (BBMemoryError (MemoryError mop rsn)) + return p' + +-- | Assert that the given LLVM pointer value is actually a raw bitvector and extract its value. +projectLLVM_bv :: + IsSymBackend sym bak => + bak -> LLVMPtr sym w -> IO (SymBV sym w) +projectLLVM_bv bak (LLVMPointer blk bv) = + do let sym = backendGetSym bak + p <- natEq sym blk =<< natLit sym 0 + assert bak p $ AssertFailureSimError "Pointer value coerced to bitvector" "" + return bv + +------------------------------------------------------------------------ +-- ** PartLLVMVal + +-- | Either an 'LLVMValue' paired with a tree of predicates explaining +-- just when it is actually valid, or a type mismatch. +data PartLLVMVal sym where + Err :: Pred sym -> PartLLVMVal sym + NoErr :: Pred sym -> LLVMVal sym -> PartLLVMVal sym + +partErr :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + MemoryErrorReason -> + IO (PartLLVMVal sym) +partErr sym errCtx rsn = + do p <- annotateME sym errCtx rsn (falsePred sym) + pure (Err p) + +attachSideCondition :: + (IsSymInterface sym, HasLLVMAnn sym) => + sym -> + CallStack -> + Pred sym -> + UB.UndefinedBehavior (RegValue' sym) -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +attachSideCondition sym callStack pnew ub pv = + case pv of + Err p -> pure (Err p) + NoErr p v -> + do p' <- andPred sym p =<< annotateUB sym callStack ub pnew + return $ NoErr p' v + +attachMemoryError :: + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + sym -> + Pred sym -> + MemoryOp sym w -> + MemoryErrorReason -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +attachMemoryError sym pnew mop rsn pv = + case pv of + Err p -> pure (Err p) + NoErr p v -> + do p' <- andPred sym p =<< annotateME sym mop rsn pnew + return $ NoErr p' v + +typeOfBitvector :: IsExpr (SymExpr sym) + => proxy sym -> SymBV sym w -> StorageType +typeOfBitvector _ = + Type.bitvectorType . Bytes.toBytes . natValue . bvWidth + +-- | An 'LLVMVal' which is always valid. +totalLLVMVal :: (IsExprBuilder sym) + => sym + -> LLVMVal sym + -> PartLLVMVal sym +totalLLVMVal sym = NoErr (truePred sym) + +-- | Take a partial value and assert its safety +assertSafe :: IsSymBackend sym bak + => bak + -> PartLLVMVal sym + -> IO (LLVMVal sym) +assertSafe bak (NoErr p v) = + do let rsn = AssertFailureSimError "Error during memory load" "" + assert bak p rsn + return v + +assertSafe bak (Err p) = do + do let sym = backendGetSym bak + let rsn = AssertFailureSimError "Error during memory load" "" + loc <- getCurrentProgramLoc sym + let err = SimError loc rsn + addProofObligation bak (LabeledPred p err) + abortExecBecause (AssertionFailure err) + +------------------------------------------------------------------------ +-- ** PartLLVMVal interface +-- + +floatToBV :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +floatToBV _ _ (NoErr p (LLVMValUndef (StorageType Float _))) = + return (NoErr p (LLVMValUndef (Type.bitvectorType 4))) + +floatToBV sym _ (NoErr p (LLVMValZero (StorageType Float _))) = + do nz <- W4I.natLit sym 0 + iz <- W4I.bvLit sym (knownNat @32) (BV.zero knownNat) + return (NoErr p (LLVMValInt nz iz)) + +floatToBV sym _ (NoErr p (LLVMValFloat Value.SingleSize v)) = + do nz <- natLit sym 0 + i <- W4IFP.iFloatToBinary sym W4IFP.SingleFloatRepr v + return (NoErr p (LLVMValInt nz i)) + +floatToBV _ _ (Err p) = pure (Err p) + +floatToBV sym errCtx (NoErr _ v) = + do let msg = "While converting from a float to a bitvector" + partErr sym errCtx $ + UnexpectedArgumentType msg [Value.llvmValStorableType v] + +doubleToBV :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +doubleToBV _ _ (NoErr p (LLVMValUndef (StorageType Double _))) = + return (NoErr p (LLVMValUndef (Type.bitvectorType 8))) + +doubleToBV sym _ (NoErr p (LLVMValZero (StorageType Double _))) = + do nz <- W4I.natLit sym 0 + iz <- W4I.bvLit sym (knownNat @64) (BV.zero knownNat) + return (NoErr p (LLVMValInt nz iz)) + +doubleToBV sym _ (NoErr p (LLVMValFloat Value.DoubleSize v)) = + do nz <- natLit sym 0 + i <- W4IFP.iFloatToBinary sym W4IFP.DoubleFloatRepr v + return (NoErr p (LLVMValInt nz i)) + +doubleToBV _ _ (Err p) = pure (Err p) + +doubleToBV sym errCtx (NoErr _ v) = + do let msg = "While converting from a double to a bitvector" + partErr sym errCtx $ + UnexpectedArgumentType msg [Value.llvmValStorableType v] + +fp80ToBV :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +fp80ToBV _ _ (NoErr p (LLVMValUndef (StorageType X86_FP80 _))) = + return (NoErr p (LLVMValUndef (Type.bitvectorType 10))) + +fp80ToBV sym _ (NoErr p (LLVMValZero (StorageType X86_FP80 _))) = + do nz <- W4I.natLit sym 0 + iz <- W4I.bvLit sym (knownNat @80) (BV.zero knownNat) + return (NoErr p (LLVMValInt nz iz)) + +fp80ToBV sym _ (NoErr p (LLVMValFloat Value.X86_FP80Size v)) = + do nz <- natLit sym 0 + i <- W4IFP.iFloatToBinary sym W4IFP.X86_80FloatRepr v + return (NoErr p (LLVMValInt nz i)) + +fp80ToBV _ _ (Err p) = pure (Err p) + +fp80ToBV sym errCtx (NoErr _ v) = + do let msg = "While converting from a FP80 to a bitvector" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + +-- | Convert a bitvector to a float, asserting that it is not a pointer +bvToFloat :: forall sym w. + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +bvToFloat sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 4) _))) = + NoErr p . LLVMValFloat Value.SingleSize <$> + (W4IFP.iFloatFromBinary sym W4IFP.SingleFloatRepr =<< + W4I.bvLit sym (knownNat @32) (BV.zero knownNat)) + +bvToFloat sym errCtx (NoErr p (LLVMValInt blk off)) + | Just Refl <- testEquality (bvWidth off) (knownNat @32) = do + pz <- natEq sym blk =<< natLit sym 0 + let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.floatType + p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz + NoErr p' . LLVMValFloat Value.SingleSize <$> + W4IFP.iFloatFromBinary sym W4IFP.SingleFloatRepr off + +bvToFloat _ _ (Err p) = pure (Err p) + +bvToFloat sym errCtx (NoErr _ v) = + do let msg = "While converting from a bitvector to a float" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + + +-- | Convert a bitvector to a double, asserting that it is not a pointer +bvToDouble :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +bvToDouble sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 8) _))) = + NoErr p . LLVMValFloat Value.DoubleSize <$> + (W4IFP.iFloatFromBinary sym W4IFP.DoubleFloatRepr =<< + W4I.bvLit sym (knownNat @64) (BV.zero knownNat)) + +bvToDouble sym errCtx (NoErr p (LLVMValInt blk off)) + | Just Refl <- testEquality (bvWidth off) (knownNat @64) = do + pz <- natEq sym blk =<< natLit sym 0 + let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.doubleType + p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz + NoErr p' . + LLVMValFloat Value.DoubleSize <$> + W4IFP.iFloatFromBinary sym W4IFP.DoubleFloatRepr off + +bvToDouble _ _ (Err p) = pure (Err p) + +bvToDouble sym errCtx (NoErr _ v) = + do let msg = "While converting from a bitvector to a double" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + + +-- | Convert a bitvector to an FP80 float, asserting that it is not a pointer +bvToX86_FP80 :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +bvToX86_FP80 sym _ (NoErr p (LLVMValZero (StorageType (Bitvector 10) _))) = + NoErr p . LLVMValFloat Value.X86_FP80Size <$> + (W4IFP.iFloatFromBinary sym W4IFP.X86_80FloatRepr =<< + W4I.bvLit sym (knownNat @80) (BV.zero knownNat)) + +bvToX86_FP80 sym errCtx (NoErr p (LLVMValInt blk off)) + | Just Refl <- testEquality (bvWidth off) (knownNat @80) = + do pz <- natEq sym blk =<< natLit sym 0 + let ub = UB.PointerFloatCast (RV (LLVMPointer blk off)) Type.x86_fp80Type + p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz + NoErr p' . LLVMValFloat Value.X86_FP80Size <$> + W4IFP.iFloatFromBinary sym W4IFP.X86_80FloatRepr off + +bvToX86_FP80 _ _ (Err p) = pure (Err p) + +bvToX86_FP80 sym errCtx (NoErr _ v) = + do let msg = "While converting from a bitvector to a X86_FP80" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + +-- | Concatenate partial LLVM bitvector values. The least-significant +-- (low) bytes are given first. The allocation block number of each +-- argument is asserted to equal 0, indicating non-pointers. +bvConcat :: forall sym w. + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +bvConcat sym errCtx (NoErr p1 v1) (NoErr p2 v2) = + case (v1, v2) of + (LLVMValInt blk_low low, LLVMValInt blk_high high) -> + do go blk_low low blk_high high + (LLVMValInt blk_low low, LLVMValZero t@(StorageType (Bitvector high_bytes) _)) -> + Value.zeroInt sym high_bytes $ \case + Nothing -> partErr sym errCtx $ TypeMismatch (typeOfBitvector (Just sym) low) t + Just (blk_high, high) -> + go blk_low low blk_high high + (LLVMValZero t@(StorageType (Bitvector low_bytes) _), LLVMValInt blk_high high) -> + Value.zeroInt sym low_bytes $ \case + Nothing -> partErr sym errCtx $ TypeMismatch (typeOfBitvector (Just sym) high) t + Just (blk_low, low) -> + go blk_low low blk_high high + (LLVMValZero (StorageType (Bitvector low_bytes) _), LLVMValZero (StorageType (Bitvector high_bytes) _)) -> + pure $ totalLLVMVal sym (LLVMValZero (Type.bitvectorType (low_bytes + high_bytes))) + (a, b) -> partErr sym errCtx $ UnexpectedArgumentType "While concatenating bitvectors" + [Value.llvmValStorableType a, Value.llvmValStorableType b] + + where + go :: forall l h. (1 <= l, 1 <= h) => + SymNat sym -> SymBV sym l -> SymNat sym -> SymBV sym h -> IO (PartLLVMVal sym) + go blk_low low blk_high high + -- NB we check that the things we are concatenating are each an integral number of + -- bytes. This prevents us from concatenating together the partial-byte writes that + -- result from e.g. writing an i1 or an i20 into memory. This is consistent with LLVM + -- documentation, which says that non-integral number of bytes loads will only succeed + -- if the value was written orignally with the same type. + | low_nat `mod` 8 == 0 + , high_nat `mod` 8 == 0 = + do blk0 <- natLit sym 0 + -- TODO: Why won't this pattern match fail? + Just LeqProof <- return $ isPosNat (addNat high_w' low_w') + let ub1 = UB.PointerIntCast (RV (LLVMPointer blk_low low)) low_tp + ub2 = UB.PointerIntCast (RV (LLVMPointer blk_high high)) high_tp + annUB = annotateUB sym (memOpCallStack errCtx) + predLow <- annUB ub1 =<< natEq sym blk_low blk0 + predHigh <- annUB ub2 =<< natEq sym blk_high blk0 + bv <- W4I.bvConcat sym high low + + p' <- andPred sym p1 =<< andPred sym p2 =<< andPred sym predLow predHigh + return $ NoErr p' (LLVMValInt blk0 bv) + + | otherwise = partErr sym errCtx $ + UnexpectedArgumentType "Non-byte-sized bitvectors" + [Value.llvmValStorableType v1, Value.llvmValStorableType v2] + + where low_w' = bvWidth low + low_nat = natValue low_w' + low_tp = Type.bitvectorType (Bytes.bitsToBytes low_nat) + + high_w' = bvWidth high + high_nat = natValue high_w' + high_tp = Type.bitvectorType (Bytes.bitsToBytes high_nat) + +bvConcat sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2 +bvConcat _ _ _ (Err e) = pure (Err e) +bvConcat _ _ (Err e) _ = pure (Err e) + +-- | Cons an element onto a partial LLVM array value. +consArray :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +consArray sym _ (NoErr p1 (LLVMValZero tp)) (NoErr p2 (LLVMValZero (StorageType (Array m tp') _))) + | tp == tp' = + do p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValZero (Type.arrayType (m+1) tp') + +consArray sym _ (NoErr p1 hd) (NoErr p2 (LLVMValZero (StorageType (Array m tp) _))) + | Value.llvmValStorableType hd == tp = + do p' <- andPred sym p1 p2 + return $ NoErr p' $ + LLVMValArray tp (V.cons hd (V.replicate (fromIntegral m) (LLVMValZero tp))) + +consArray sym _ (NoErr p1 (LLVMValInt blk off)) (NoErr p2 (LLVMValString bs)) + | Just Refl <- testEquality (bvWidth off) (knownNat @8) + , Just 0 <- asNat blk + , Just bv <- asBV off + = do p' <- andPred sym p1 p2 + return $ NoErr p' (LLVMValString (BS.cons (fromInteger (BV.asUnsigned bv)) bs)) + +consArray sym errCtx (NoErr p1 v) (NoErr p2 (LLVMValString bs)) + = consArray sym errCtx (NoErr p1 v) . NoErr p2 =<< Value.explodeStringValue sym bs + +consArray sym _ (NoErr p1 hd) (NoErr p2 (LLVMValArray tp vec)) + | Value.llvmValStorableType hd == tp = + do p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValArray tp (V.cons hd vec) + +consArray sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2 +consArray _ _ (Err e) _ = pure (Err e) +consArray _ _ _ (Err e) = pure (Err e) + +consArray sym errCtx _ (NoErr _ v) = + partErr sym errCtx $ UnexpectedArgumentType "Non-array value" [Value.llvmValStorableType v] + +-- | Append two partial LLVM array values. +appendArray :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + PartLLVMVal sym -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +appendArray sym _ + (NoErr p1 (LLVMValZero (StorageType (Array n1 tp1) _))) + (NoErr p2 (LLVMValZero (StorageType (Array n2 tp2) _))) + | tp1 == tp2 = + do p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValZero (Type.arrayType (n1+n2) tp1) + +appendArray sym _ + (NoErr p1 (LLVMValString bs1)) + (NoErr p2 (LLVMValString bs2)) + = do p' <- andPred sym p1 p2 + pure $ NoErr p' $ LLVMValString (bs1 <> bs2) + +appendArray sym errCtx (NoErr p1 (LLVMValString bs1)) (NoErr p2 v2) + = do bsv <- Value.explodeStringValue sym bs1 + appendArray sym errCtx (NoErr p1 bsv) (NoErr p2 v2) + +appendArray sym errCtx (NoErr p1 v1) (NoErr p2 (LLVMValString bs2)) + = do bsv <- Value.explodeStringValue sym bs2 + appendArray sym errCtx (NoErr p1 v1) (NoErr p2 bsv) + +appendArray sym _ + (NoErr p1 (LLVMValZero (StorageType (Array n1 tp1) _))) + (NoErr p2 (LLVMValArray tp2 v2)) + | tp1 == tp2 = + do let v1 = V.replicate (fromIntegral n1) (LLVMValZero tp1) + p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2) + +appendArray sym _ + (NoErr p1 (LLVMValArray tp1 v1)) + (NoErr p2 (LLVMValZero (StorageType (Array n2 tp2) _))) + | tp1 == tp2 = + do let v2 = V.replicate (fromIntegral n2) (LLVMValZero tp1) + p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2) + +appendArray sym _ + (NoErr p1 (LLVMValArray tp1 v1)) + (NoErr p2 (LLVMValArray tp2 v2)) + | tp1 == tp2 = + do p' <- andPred sym p1 p2 + return $ NoErr p' $ LLVMValArray tp1 (v1 V.++ v2) + +appendArray sym _ (Err e1) (Err e2) = Err <$> andPred sym e1 e2 +appendArray _ _ (Err e) _ = pure (Err e) +appendArray _ _ _ (Err e) = pure (Err e) + +appendArray sym errCtx (NoErr _ v1) (NoErr _ v2) = + partErr sym errCtx $ UnexpectedArgumentType "Non-array value when appending arrays" + [Value.llvmValStorableType v1, Value.llvmValStorableType v2] + +-- | Make a partial LLVM array value. +-- +-- It returns 'Err' if any of the elements of the vector are +-- 'Err'. Otherwise, the 'Pred' on the returned 'NoErr' value +-- is the 'And' of all the assertions on the values. +mkArray :: forall sym. (IsExprBuilder sym, IsSymInterface sym) => + sym -> + StorageType -> + Vector (PartLLVMVal sym) -> + IO (PartLLVMVal sym) +mkArray sym tp vec = + do let f :: PartLLVMVal sym -> StateT (Pred sym) (ExceptT (Pred sym) IO) (LLVMVal sym) + f (Err e) = throwError e + f (NoErr p x) = do + pd <- get -- Current predicates + pd' <- liftIO $ andPred sym pd p + put pd' -- Append this one + return x + (runExceptT $ flip runStateT (truePred sym) $ traverse f vec) >>= \case + Left e -> pure $ Err e + Right (vec', p) -> return $ NoErr p (LLVMValArray tp vec') + + +-- | Make a partial LLVM struct value. +-- +-- It returns 'Err' if any of the struct fields are 'Err'. +-- Otherwise, the 'Pred' on the returned 'NoErr' value is the 'And' of all the +-- assertions on the values. +mkStruct :: forall sym. IsExprBuilder sym => + sym -> + Vector (Field StorageType, PartLLVMVal sym) -> + IO (PartLLVMVal sym) +mkStruct sym vec = + do let f :: (Field StorageType, PartLLVMVal sym) -> + StateT (Pred sym) (ExceptT (Pred sym) IO) (Field StorageType, LLVMVal sym) + f (_, Err e) = throwError e + f (fld, NoErr p x) = do + pd <- get + pd' <- liftIO $ andPred sym pd p + put pd' + pure (fld, x) + + (runExceptT $ flip runStateT (truePred sym) $ traverse f vec) >>= \case + Left e -> pure (Err e) + Right (vec',p) -> return $ NoErr p (LLVMValStruct vec') + +-- | Select some of the least significant bytes of a partial LLVM +-- bitvector value. The allocation block number of the argument is +-- asserted to equal 0, indicating a non-pointer. +selectLowBv :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + Bytes -> + Bytes -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +selectLowBv _sym _ low hi (NoErr p (LLVMValZero (StorageType (Bitvector bytes) _))) + | low + hi == bytes = + return $ NoErr p $ LLVMValZero (Type.bitvectorType low) + +selectLowBv sym errCtx low hi (NoErr p (LLVMValInt blk bv)) + | Just (Some (low_w)) <- someNat (Bytes.bytesToBits low) + , Just (Some (hi_w)) <- someNat (Bytes.bytesToBits hi) + , Just LeqProof <- isPosNat low_w + , Just Refl <- testEquality (addNat low_w hi_w) w + , Just LeqProof <- testLeq low_w w = + do pz <- natEq sym blk =<< natLit sym 0 + bv' <- bvSelect sym (knownNat :: NatRepr 0) low_w bv + let ub = UB.PointerIntCast (RV (LLVMPointer blk bv)) tp + p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz + return $ NoErr p' $ LLVMValInt blk bv' + where w = bvWidth bv + tp = Type.bitvectorType (Bytes.bitsToBytes (natValue w)) + +selectLowBv sym errCtx _ _ (NoErr _ v) = + do let msg = "While selecting the low bits of a bitvector" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + +selectLowBv _ _ _ _ (Err e) = pure (Err e) + +-- | Select some of the most significant bytes of a partial LLVM +-- bitvector value. The allocation block number of the argument is +-- asserted to equal 0, indicating a non-pointer. +selectHighBv :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + Bytes -> + Bytes -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) + +selectHighBv _sym _ low hi (NoErr p (LLVMValZero (StorageType (Bitvector bytes) _))) + | low + hi == bytes = + return $ NoErr p $ LLVMValZero (Type.bitvectorType hi) + +selectHighBv sym errCtx low hi (NoErr p (LLVMValInt blk bv)) + | Just (Some (low_w)) <- someNat (Bytes.bytesToBits low) + , Just (Some (hi_w)) <- someNat (Bytes.bytesToBits hi) + , Just LeqProof <- isPosNat hi_w + , Just Refl <- testEquality (addNat low_w hi_w) w = + do pz <- natEq sym blk =<< natLit sym 0 + bv' <- bvSelect sym low_w hi_w bv + let ub = UB.PointerIntCast (RV (LLVMPointer blk bv)) tp + p' <- andPred sym p =<< annotateUB sym (memOpCallStack errCtx) ub pz + return $ NoErr p' $ LLVMValInt blk bv' + where w = bvWidth bv + tp = Type.bitvectorType (Bytes.bitsToBytes (natValue w)) +selectHighBv _ _ _ _ (Err e) = pure (Err e) + +selectHighBv sym errCtx _ _ (NoErr _ v) = + do let msg = "While selecting the high bits of a bitvector" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + + +-- | Look up an element in a partial LLVM array value. +arrayElt :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + Natural -> + StorageType -> + Natural -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +arrayElt _ _ sz tp idx (NoErr p (LLVMValZero _)) -- TODO(langston) typecheck + | 0 <= idx + , idx < sz = + return $ NoErr p (LLVMValZero tp) + +arrayElt sym _ sz tp idx (NoErr p (LLVMValString bs)) + | sz == fromIntegral (BS.length bs) + , 0 <= idx + , idx < sz + , tp == Type.bitvectorType (Bytes.Bytes 1) + = do blk <- natLit sym 0 + off <- bvLit sym (knownNat @8) (BV.word8 (BS.index bs (fromIntegral idx))) + return $ NoErr p (LLVMValInt blk off) + +arrayElt _ _ sz tp idx (NoErr p (LLVMValArray tp' vec)) + | sz == fromIntegral (V.length vec) + , 0 <= idx + , idx < sz + , tp == tp' = + return $ NoErr p (vec V.! fromIntegral idx) + +arrayElt _ _ _ _ _ (Err e) = pure (Err e) + +arrayElt sym errCtx _ _ _ (NoErr _ v) = + do let msg = "While selecting and element of an array" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + +-- | Look up a field in a partial LLVM struct value. +fieldVal :: + (IsSymInterface sym, HasLLVMAnn sym, 1 <= w) => + sym -> + MemoryOp sym w -> + (Vector (Field StorageType)) -> + Int -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +fieldVal _ _ flds idx (NoErr p (LLVMValZero _)) -- TODO(langston) typecheck + | 0 <= idx + , idx < V.length flds = + return $ NoErr p $ LLVMValZero $ view Type.fieldVal $ flds V.! idx + +fieldVal _ _ flds idx (NoErr p (LLVMValStruct vec)) + | flds == fmap fst vec + , 0 <= idx + , idx < V.length vec = + return $ NoErr p $ snd $ (vec V.! idx) + +fieldVal _ _ _ _ (Err e) = pure (Err e) + +fieldVal sym errCtx _ _ (NoErr _ v) = + do let msg = "While getting a struct field" + partErr sym errCtx $ UnexpectedArgumentType msg [Value.llvmValStorableType v] + +------------------------------------------------------------------------ +-- ** Merging and muxing +-- + +-- | If-then-else on partial expressions. +merge :: forall sym m. (IsSymInterface sym, HasLLVMAnn sym, MonadIO m) => + sym -> + (Pred sym -> LLVMVal sym -> LLVMVal sym -> m (LLVMVal sym)) + {- ^ Operation to combine inner values. The 'Pred' parameter is the + if/then/else condition -} -> + Pred sym {- ^ condition to merge on -} -> + PartLLVMVal sym {- ^ 'then' value -} -> + PartLLVMVal sym {- ^ 'else' value -} -> + m (PartLLVMVal sym) +merge sym _ c (Err e1) (Err e2) = Err <$> liftIO (itePred sym c e1 e2) + +merge sym _ cond (NoErr p v) (Err pe) = + do p' <- liftIO (itePred sym cond p pe) + pure $ NoErr p' v +merge sym _ cond (Err pe) (NoErr p v) = do + do p' <- liftIO (itePred sym cond pe p) + pure $ NoErr p' v +merge sym f cond (NoErr px x) (NoErr py y) = do + v <- f cond x y + p' <- liftIO (itePred sym cond px py) + return $ NoErr p' v + +-- | Mux partial LLVM values. +-- +-- Will @panic@ if the values are not structurally related. +-- This should never happen, as we only call @muxLLVMVal@ +-- from inside the memory model as we read values, and the +-- shape of values is determined by the memory type +-- at which we read values. +muxLLVMVal :: forall sym. + (IsSymInterface sym, HasLLVMAnn sym) => + sym -> + Pred sym -> + PartLLVMVal sym -> + PartLLVMVal sym -> + IO (PartLLVMVal sym) +muxLLVMVal sym = merge sym muxval + where + + muxzero :: Pred sym -> StorageType -> LLVMVal sym -> IO (LLVMVal sym) + muxzero cond tpz val = case val of + LLVMValZero tp -> return $ LLVMValZero tp + LLVMValUndef tpu -> + -- TODO: Is this the right behavior? + panic "Cannot mux zero and undef" [ "Zero type: " ++ show tpz + , "Undef type: " ++ show tpu + ] + + LLVMValString bs -> muxzero cond tpz =<< Value.explodeStringValue sym bs + + LLVMValInt base off -> + do zbase <- W4I.natLit sym 0 + zoff <- W4I.bvLit sym (W4I.bvWidth off) (BV.zero (W4I.bvWidth off)) + base' <- W4I.natIte sym cond zbase base + off' <- W4I.bvIte sym cond zoff off + return $ LLVMValInt base' off' + LLVMValFloat Value.SingleSize x -> + do zerof <- (W4IFP.iFloatLitRational sym W4IFP.SingleFloatRepr 0) + x' <- (W4IFP.iFloatIte @_ @W4IFP.SingleFloat sym cond zerof x) + return $ LLVMValFloat Value.SingleSize x' + LLVMValFloat Value.DoubleSize x -> + do zerof <- (W4IFP.iFloatLitRational sym W4IFP.DoubleFloatRepr 0) + x' <- (W4IFP.iFloatIte @_ @W4IFP.DoubleFloat sym cond zerof x) + return $ LLVMValFloat Value.DoubleSize x' + LLVMValFloat Value.X86_FP80Size x -> + do zerof <- (W4IFP.iFloatLitRational sym W4IFP.X86_80FloatRepr 0) + x' <- (W4IFP.iFloatIte @_ @W4IFP.X86_80Float sym cond zerof x) + return $ LLVMValFloat Value.X86_FP80Size x' + + LLVMValArray tp vec -> LLVMValArray tp <$> + traverse (muxzero cond tp) vec + + LLVMValStruct flds -> LLVMValStruct <$> + traverse (\(fld, v) -> (fld,) <$> + muxzero cond (fld^.Type.fieldVal) v) flds + + + muxval :: Pred sym -> LLVMVal sym -> LLVMVal sym -> IO (LLVMVal sym) + muxval cond (LLVMValZero tp) v = muxzero cond tp v + muxval cond v (LLVMValZero tp) = do cond' <- notPred sym cond + muxzero cond' tp v + + muxval cond (LLVMValInt base1 off1) (LLVMValInt base2 off2) + | Just Refl <- testEquality (bvWidth off1) (bvWidth off2) + = do base <- liftIO $ natIte sym cond base1 base2 + off <- liftIO $ bvIte sym cond off1 off2 + pure $ LLVMValInt base off + + muxval cond (LLVMValFloat (xsz :: Value.FloatSize fi) x) (LLVMValFloat ysz y) + | Just Refl <- testEquality xsz ysz + = LLVMValFloat xsz <$> + (liftIO $ W4IFP.iFloatIte @_ @fi sym cond x y) + + muxval cond (LLVMValStruct fls1) (LLVMValStruct fls2) + | fmap fst fls1 == fmap fst fls2 = + LLVMValStruct <$> + V.zipWithM (\(f, x) (_, y) -> (f,) <$> muxval cond x y) fls1 fls2 + + muxval cond (LLVMValString bs1) (LLVMValString bs2) + | bs1 == bs2 = pure (LLVMValString bs1) + | BS.length bs1 == BS.length bs2 + = do v1 <- Value.explodeStringValue sym bs1 + v2 <- Value.explodeStringValue sym bs2 + muxval cond v1 v2 + + muxval cond (LLVMValString bs) v@LLVMValArray{} + = do bsv <- Value.explodeStringValue sym bs + muxval cond bsv v + + muxval cond v@LLVMValArray{} (LLVMValString bs) + = do bsv <- Value.explodeStringValue sym bs + muxval cond v bsv + + muxval cond (LLVMValArray tp1 v1) (LLVMValArray tp2 v2) + | tp1 == tp2 && V.length v1 == V.length v2 = do + LLVMValArray tp1 <$> V.zipWithM (muxval cond) v1 v2 + + muxval _ v1@(LLVMValUndef tp1) (LLVMValUndef tp2) + | tp1 == tp2 = pure v1 + + muxval _ v1 v2 = + panic "Cannot mux LLVM values" + [ "v1: " ++ show v1 + , "v2: " ++ show v2 + ] diff --git a/src/Lang/Crucible/LLVM/MemModel/Pointer.hs b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs @@ -0,0 +1,350 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Pointer +-- Description : Representation of pointers in the LLVM memory model +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Lang.Crucible.LLVM.MemModel.Pointer + ( -- * Pointer bitwidth + HasPtrWidth + , pattern PtrWidth + , withPtrWidth + + -- * Crucible pointer representation + , LLVMPointerType + , LLVMPtr + , SomePointer(..) + , pattern LLVMPointerRepr + , pattern PtrRepr + , pattern SizeT + , pattern LLVMPointer + , ptrWidth + , llvmPointerView + , llvmPointerBlock + , llvmPointerOffset + , llvmPointerType + , muxLLVMPtr + , llvmPointer_bv + , mkNullPointer + + -- * Concretization + , concBV + , concPtr + , concPtr' + + -- * Operations on valid pointers + , constOffset + , ptrEq + , ptrLe + , ptrAdd + , ptrDiff + , ptrSub + , ptrIsNull + , isGlobalPointer + , isGlobalPointer' + + -- * Pretty printing + , ppPtr + + -- * Annotation + , annotatePointerBlock + , annotatePointerOffset + ) where + +import Control.Monad (guard) +import Data.Map (Map) +import qualified Data.Map as Map (lookup) +import Numeric.Natural +import Prettyprinter + +import GHC.TypeLits (TypeError, ErrorMessage(..)) +import GHC.TypeNats + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr +import qualified Text.LLVM.AST as L + +import What4.Interface +import What4.InterpretedFloatingPoint +import What4.Expr (GroundValue) + +import Lang.Crucible.Backend +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Types +import qualified Lang.Crucible.LLVM.Bytes as G +import Lang.Crucible.LLVM.Types +import Lang.Crucible.LLVM.MemModel.Options + + + +data LLVMPointer sym w = + -- |A pointer is a base point offset. + LLVMPointer (SymNat sym) (SymBV sym w) + +deriving instance (Show (SymNat sym), Show (SymBV sym w)) => Show (LLVMPointer sym w) + +llvmPointerBlock :: LLVMPtr sym w -> SymNat sym +llvmPointerBlock (LLVMPointer blk _) = blk + +llvmPointerOffset :: LLVMPtr sym w -> SymBV sym w +llvmPointerOffset (LLVMPointer _ off) = off + +llvmPointerType :: IsExpr (SymExpr sym) => LLVMPtr sym w -> TypeRepr (LLVMPointerType w) +llvmPointerType ptr = + case exprType (llvmPointerOffset ptr) of + BaseBVRepr w -> LLVMPointerRepr w + +-- | Type family defining how @LLVMPointerType@ unfolds. +type family LLVMPointerImpl sym ctx where + LLVMPointerImpl sym (EmptyCtx ::> BVType w) = LLVMPointer sym w + LLVMPointerImpl sym ctx = TypeError ('Text "LLVM_pointer expects a single argument of BVType, but was given" ':<>: + 'ShowType ctx) + +-- | A pointer with an existentially-quantified width +data SomePointer sym = forall w. (1 <= w) => SomePointer !(LLVMPtr sym w) + +instance (IsSymInterface sym) => IntrinsicClass sym "LLVM_pointer" where + type Intrinsic sym "LLVM_pointer" ctx = LLVMPointerImpl sym ctx + + muxIntrinsic sym _iTypes _nm (Ctx.Empty Ctx.:> (BVRepr _w)) = muxLLVMPtr sym + muxIntrinsic _ _ nm ctx = typeError nm ctx + +-- | Alternative to the 'LLVMPointer' pattern synonym, this function can be used as a view +-- constructor instead to silence incomplete pattern warnings. +llvmPointerView :: LLVMPtr sym w -> (SymNat sym, SymBV sym w) +llvmPointerView (LLVMPointer blk off) = (blk, off) + +-- | Compute the width of a pointer value. +ptrWidth :: IsExprBuilder sym => LLVMPtr sym w -> NatRepr w +ptrWidth (LLVMPointer _blk bv) = bvWidth bv + +-- | Convert a raw bitvector value into an LLVM pointer value. +llvmPointer_bv :: IsSymInterface sym => sym -> SymBV sym w -> IO (LLVMPtr sym w) +llvmPointer_bv sym bv = + do blk0 <- natLit sym 0 + return (LLVMPointer blk0 bv) + +-- | Produce the distinguished null pointer value. +mkNullPointer :: (1 <= w, IsSymInterface sym) => sym -> NatRepr w -> IO (LLVMPtr sym w) +mkNullPointer sym w = llvmPointer_bv sym =<< bvLit sym w (BV.zero w) + + +concBV :: + (IsExprBuilder sym, 1 <= w) => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + SymBV sym w -> IO (SymBV sym w) +concBV sym conc bv = + do bv' <- conc bv + bvLit sym (bvWidth bv) bv' + +concPtr :: + (IsExprBuilder sym, 1 <= w) => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + RegValue sym (LLVMPointerType w) -> + IO (RegValue sym (LLVMPointerType w)) +concPtr sym conc (LLVMPointer blk off) = + do blk' <- integerToNat sym =<< intLit sym =<< conc =<< natToInteger sym blk + off' <- concBV sym conc off + pure (LLVMPointer blk' off') + +concPtr' :: + (IsExprBuilder sym, 1 <= w) => + sym -> + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + RegValue' sym (LLVMPointerType w) -> + IO (RegValue' sym (LLVMPointerType w)) +concPtr' sym conc (RV ptr) = RV <$> concPtr sym conc ptr + + +-- | Mux function specialized to LLVM pointer values. +muxLLVMPtr :: + (1 <= w) => + IsSymInterface sym => + sym -> + Pred sym -> + LLVMPtr sym w -> + LLVMPtr sym w -> + IO (LLVMPtr sym w) +muxLLVMPtr sym p (LLVMPointer b1 off1) (LLVMPointer b2 off2) = + do b <- natIte sym p b1 b2 + off <- bvIte sym p off1 off2 + return $ LLVMPointer b off + +data FloatSize (fi :: FloatInfo) where + SingleSize :: FloatSize SingleFloat + DoubleSize :: FloatSize DoubleFloat + +deriving instance Eq (FloatSize fi) + +deriving instance Ord (FloatSize fi) + +deriving instance Show (FloatSize fi) + +instance TestEquality FloatSize where + testEquality SingleSize SingleSize = Just Refl + testEquality DoubleSize DoubleSize = Just Refl + testEquality _ _ = Nothing + +-- | Generate a concrete offset value from an @Addr@ value. +constOffset :: (1 <= w, IsExprBuilder sym) => sym -> NatRepr w -> G.Addr -> IO (SymBV sym w) +constOffset sym w x = bvLit sym w (G.bytesToBV w x) + +-- | Test whether two pointers are equal. +ptrEq :: (1 <= w, IsSymInterface sym) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> LLVMPtr sym w + -> IO (Pred sym) +ptrEq sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2) = + do p1 <- natEq sym base1 base2 + p2 <- bvEq sym off1 off2 + andPred sym p1 p2 + +-- | Test whether one pointer is less than or equal to the other. +-- +-- The returned predicates assert (in this order): +-- * the first pointer is less than or equal to the second +-- * the comparison is valid: the pointers are to the same allocation +ptrLe :: (1 <= w, IsSymInterface sym, ?memOpts :: MemOptions) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> LLVMPtr sym w + -> IO (Pred sym, Pred sym) +ptrLe sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2) + | laxPointerOrdering ?memOpts + = do plt <- natLt sym base1 base2 + peq <- natEq sym base1 base2 + bvle <- bvUle sym off1 off2 + + p <- orPred sym plt =<< andPred sym peq bvle + return (p, truePred sym) + + | otherwise + = do peq <- natEq sym base1 base2 + bvle <- bvUle sym off1 off2 + return (bvle, peq) + +-- | Add an offset to a pointer. +ptrAdd :: (1 <= w, IsExprBuilder sym) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> SymBV sym w + -> IO (LLVMPtr sym w) +ptrAdd sym _w (LLVMPointer base off1) off2 = + LLVMPointer base <$> bvAdd sym off1 off2 + +-- | Compute the difference between two pointers. The returned predicate asserts +-- that the pointers point into the same allocation block. +ptrDiff :: (1 <= w, IsSymInterface sym) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> LLVMPtr sym w + -> IO (SymBV sym w, Pred sym) +ptrDiff sym _w (LLVMPointer base1 off1) (LLVMPointer base2 off2) = + (,) <$> bvSub sym off1 off2 <*> natEq sym base1 base2 + +-- | Subtract an offset from a pointer. +ptrSub :: (1 <= w, IsSymInterface sym) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> SymBV sym w + -> IO (LLVMPtr sym w) +ptrSub sym _w (LLVMPointer base off1) off2 = + do diff <- bvSub sym off1 off2 + return (LLVMPointer base diff) + +-- | Test if a pointer value is the null pointer. +ptrIsNull :: (1 <= w, IsSymInterface sym) + => sym + -> NatRepr w + -> LLVMPtr sym w + -> IO (Pred sym) +ptrIsNull sym w (LLVMPointer blk off) = + do pblk <- natEq sym blk =<< natLit sym 0 + poff <- bvEq sym off =<< bvLit sym (bvWidth off) (BV.zero w) + andPred sym pblk poff + +ppPtr :: IsExpr (SymExpr sym) => LLVMPtr sym wptr -> Doc ann +ppPtr (llvmPointerView -> (blk, bv)) + | Just 0 <- asNat blk = printSymExpr bv + | otherwise = + let blk_doc = printSymNat blk + off_doc = printSymExpr bv + in pretty "(" <> blk_doc <> pretty "," <+> off_doc <> pretty ")" + +-- | Look up a pointer in the 'memImplGlobalMap' to see if it's a global. +-- +-- This is best-effort and will only work if the pointer is fully concrete +-- and matches the address of the global on the nose. It is used in SAWscript +-- for friendly error messages. +isGlobalPointer :: + forall sym w. (IsSymInterface sym) => + Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} -> + LLVMPtr sym w -> Maybe L.Symbol +isGlobalPointer symbolMap needle = + do n <- asNat (llvmPointerBlock needle) + z <- asBV (llvmPointerOffset needle) + guard (BV.asUnsigned z == 0) + Map.lookup n symbolMap + +-- | For when you don't know @1 <= w@ +isGlobalPointer' :: + forall sym w. (IsSymInterface sym) => + Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} -> + LLVMPtr sym w -> Maybe L.Symbol +isGlobalPointer' symbolMap needle = + case testLeq (knownNat :: NatRepr 1) (ptrWidth needle) of + Nothing -> Nothing + Just LeqProof -> isGlobalPointer symbolMap needle + +annotatePointerBlock :: + forall sym w. (IsSymInterface sym) => + sym -> + LLVMPtr sym w -> + IO (SymAnnotation sym BaseIntegerType, LLVMPointer sym w) +annotatePointerBlock sym (LLVMPointer blk off) = + do (annotation, annotatedBlkInt) <- annotateTerm sym =<< natToInteger sym blk + annotatedBlkNat <- integerToNat sym annotatedBlkInt + pure (annotation, LLVMPointer annotatedBlkNat off) + +annotatePointerOffset :: + forall sym w. (IsSymInterface sym) => + sym -> + LLVMPtr sym w -> + IO (SymAnnotation sym (BaseBVType w), LLVMPointer sym w) +annotatePointerOffset sym (LLVMPointer blk off) = + do (annotation, annotatedOff) <- annotateTerm sym off + pure (annotation, LLVMPointer blk annotatedOff) diff --git a/src/Lang/Crucible/LLVM/MemModel/Type.hs b/src/Lang/Crucible/LLVM/MemModel/Type.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Type.hs @@ -0,0 +1,167 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Type +-- Description : Representation of storable types used by the memory model +-- Copyright : (c) Galois, Inc 2011-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Lang.Crucible.LLVM.MemModel.Type + ( -- * Storable types + StorageType(..) + , StorageTypeF(..) + , bitvectorType + , floatType + , doubleType + , x86_fp80Type + , arrayType + , structType + , mkStructType + , mkStorageType + , typeEnd + , Field + , fieldVal + , fieldPad + , fieldOffset + , mkField + , ppType + ) where + +import Control.Lens +import Control.Monad.State +import Data.Typeable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural +import Prettyprinter + +import Lang.Crucible.LLVM.Bytes + +data Field v = + Field + { fieldOffset :: !Offset + , _fieldVal :: !v + , fieldPad :: !Bytes + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Typeable) + +fieldVal :: Lens (Field a) (Field b) a b +fieldVal = lens _fieldVal (\s v -> s { _fieldVal = v }) + +mkField :: Offset -> v -> Bytes -> Field v +mkField = Field + +data StorageTypeF v + = Bitvector !Bytes -- ^ Size of bitvector in bytes (must be > 0). + | Float + | Double + | X86_FP80 + | Array !Natural !v -- ^ Number of elements and element type + | Struct !(Vector (Field v)) + deriving (Eq, Ord, Show, Typeable) + +-- | Represents the storage type of an LLVM value. A 'Type' specifies +-- how a value is represented as bytes in memory. +data StorageType = + StorageType + { storageTypeF :: !(StorageTypeF StorageType) + , storageTypeSize :: !Bytes + } + deriving (Eq, Ord, Typeable) + +instance Show StorageType where + showsPrec p t = showParen (p >= 10) $ + case storageTypeF t of + Bitvector w -> showString "bitvectorType " . shows w + Float -> showString "float" + Double -> showString "double" + X86_FP80 -> showString "long double" + Array n tp -> showString "arrayType " . shows n . showString " " . showsPrec 10 tp + Struct v -> showString "mkStructType " . shows (V.toList (fldFn <$> v)) + where fldFn f = (f^.fieldVal, fieldPad f) + +mkStorageType :: StorageTypeF StorageType -> StorageType +mkStorageType tf = StorageType tf $ + case tf of + Bitvector w -> w + Float -> 4 + Double -> 8 + X86_FP80 -> 10 + Array n e -> natBytesMul n (storageTypeSize e) + Struct flds -> structSize flds + +bitvectorType :: Bytes -> StorageType +bitvectorType w = StorageType (Bitvector w) w + +floatType :: StorageType +floatType = mkStorageType Float + +doubleType :: StorageType +doubleType = mkStorageType Double + +x86_fp80Type :: StorageType +x86_fp80Type = mkStorageType X86_FP80 + +arrayType :: Natural -> StorageType -> StorageType +arrayType n e = StorageType (Array n e) (natBytesMul n (storageTypeSize e)) + +structType :: V.Vector (Field StorageType) -> StorageType +structType flds = StorageType (Struct flds) (structSize flds) + +mkStructType :: V.Vector (StorageType, Bytes) -> StorageType +mkStructType l = structType (evalState (traverse fldFn l) 0) + where + fldFn (tp,p) = + do o <- get + put $! o + storageTypeSize tp + p + return Field { fieldOffset = o + , _fieldVal = tp + , fieldPad = p + } + +-- | Returns end of actual type bytes (excluded padding from structs). +typeEnd :: Addr -> StorageType -> Addr +typeEnd a tp = seq a $ + case storageTypeF tp of + Bitvector w -> a + w + Float -> a + 4 + Double -> a + 8 + X86_FP80 -> a + 10 + Array 0 _ -> a + Array n etp -> typeEnd (a + natBytesMul (n-1) (storageTypeSize etp)) etp + Struct flds -> + case V.unsnoc flds of + Just (_, f) -> typeEnd (a + fieldOffset f) (f^.fieldVal) + Nothing -> a + +-- | Returns end of field including padding bytes. +structSize :: V.Vector (Field StorageType) -> Bytes +structSize flds = + case V.unsnoc flds of + Just (_, f) -> fieldEnd f + Nothing -> 0 + +-- | Returns end of field including padding bytes. +fieldEnd :: Field StorageType -> Bytes +fieldEnd f = fieldOffset f + storageTypeSize (f^.fieldVal) + fieldPad f + + +-- | Pretty print type. +ppType :: StorageType -> Doc ann +ppType tp = + case storageTypeF tp of + Bitvector w -> pretty 'i' <> pretty (bytesToBits w) + Float -> pretty "float" + Double -> pretty "double" + X86_FP80 -> pretty "long double" + Array n etp -> brackets (pretty n <+> pretty 'x' <+> ppType etp) + Struct flds -> braces $ hsep $ punctuate (pretty ',') $ V.toList $ ppFld <$> flds + where ppFld f = ppType (f^.fieldVal) diff --git a/src/Lang/Crucible/LLVM/MemModel/Value.hs b/src/Lang/Crucible/LLVM/MemModel/Value.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemModel/Value.hs @@ -0,0 +1,420 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemModel.Value +-- Description : Representation of values in the LLVM memory model +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Lang.Crucible.LLVM.MemModel.Value + ( -- * LLVM Value representation + LLVMVal(..) + , ppLLVMValWithGlobals + , FloatSize(..) + , Field + , ptrToPtrVal + , zeroInt + , ppTermExpr + , explodeStringValue + + , llvmValStorableType + , freshLLVMVal + , isZero + , testEqual + ) where + +import Control.Lens (view, over, _2, (^.)) +import Control.Monad (foldM, join) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Map (Map) +import Data.Foldable (toList) +import Data.Functor.Identity (Identity(..)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.List (intersperse) +import Numeric.Natural +import Prettyprinter + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Text.LLVM.AST as L + +import What4.Interface +import What4.InterpretedFloatingPoint + +import Lang.Crucible.Backend +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.MemModel.Type +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.Panic (panic) + +data FloatSize (fi :: FloatInfo) where + SingleSize :: FloatSize SingleFloat + DoubleSize :: FloatSize DoubleFloat + X86_FP80Size :: FloatSize X86_80Float + +deriving instance Eq (FloatSize fi) +deriving instance Ord (FloatSize fi) +deriving instance Show (FloatSize fi) +instance TestEquality FloatSize where + testEquality SingleSize SingleSize = Just Refl + testEquality DoubleSize DoubleSize = Just Refl + testEquality X86_FP80Size X86_FP80Size = Just Refl + testEquality _ _ = Nothing + +-- | This datatype describes the variety of values that can be stored in +-- the LLVM heap. +data LLVMVal sym where + -- | NOTE! The ValInt constructor uniformly represents both pointers and + -- raw bitvector values. The 'SymNat' value is an allocation block number + -- that identifies specific allocations. The block number '0' is special, + -- and indicates that this value is actually a bitvector. Non-zero block + -- numbers correspond to pointer values, where the 'SymBV' value is an + -- offset from the base pointer of the allocation. + LLVMValInt :: (1 <= w) => SymNat sym -> SymBV sym w -> LLVMVal sym + LLVMValFloat :: FloatSize fi -> SymInterpretedFloat sym fi -> LLVMVal sym + LLVMValStruct :: Vector (Field StorageType, LLVMVal sym) -> LLVMVal sym + LLVMValArray :: StorageType -> Vector (LLVMVal sym) -> LLVMVal sym + + -- | LLVM Value Data given by a constant string of bytes + LLVMValString :: ByteString -> LLVMVal sym + + -- | The zero value exists at all storage types, and represents the the value + -- which is obtained by loading the approprite number of all zero bytes. + -- It is useful for compactly representing large zero-initialized data structures. + LLVMValZero :: StorageType -> LLVMVal sym + + -- | The @undef@ value exists at all storage types. + LLVMValUndef :: StorageType -> LLVMVal sym + + +llvmValStorableType :: IsExprBuilder sym => LLVMVal sym -> StorageType +llvmValStorableType v = + case v of + LLVMValInt _ bv -> bitvectorType (bitsToBytes (natValue (bvWidth bv))) + LLVMValFloat SingleSize _ -> floatType + LLVMValFloat DoubleSize _ -> doubleType + LLVMValFloat X86_FP80Size _ -> x86_fp80Type + LLVMValStruct fs -> structType (fmap fst fs) + LLVMValArray tp vs -> arrayType (fromIntegral (V.length vs)) tp + LLVMValString bs -> arrayType (fromIntegral (BS.length bs)) (bitvectorType (Bytes 1)) + LLVMValZero tp -> tp + LLVMValUndef tp -> tp + +-- | Create a fresh 'LLVMVal' of the given type. +freshLLVMVal :: IsSymInterface sym => + sym -> StorageType -> IO (LLVMVal sym) +freshLLVMVal sym tp = + case storageTypeF tp of + Bitvector bytes -> + case mkNatRepr (bytesToBits bytes) of + Some repr -> + case isPosNat repr of + Just LeqProof -> LLVMValInt <$> natLit sym 0 + <*> freshConstant sym emptySymbol (BaseBVRepr repr) + Nothing -> panic "freshLLVMVal" ["Non-positive value inside Bytes"] + Float -> LLVMValFloat SingleSize <$> freshFloatConstant sym emptySymbol SingleFloatRepr + Double -> LLVMValFloat DoubleSize <$> freshFloatConstant sym emptySymbol DoubleFloatRepr + X86_FP80 -> LLVMValFloat X86_FP80Size <$> freshFloatConstant sym emptySymbol X86_80FloatRepr + Array n ty -> LLVMValArray ty <$> V.replicateM (fromIntegral n) (freshLLVMVal sym ty) + Struct vec -> LLVMValStruct <$> traverse (\v -> (v,) <$> freshLLVMVal sym (v^.fieldVal)) vec + +ppTermExpr :: forall sym ann. + IsExpr (SymExpr sym) => LLVMVal sym -> Doc ann +ppTermExpr t = -- FIXME, do something with the predicate? + case t of + LLVMValZero _tp -> pretty "0" + LLVMValUndef tp -> pretty " viaShow tp <> pretty ">" + LLVMValString bs -> viaShow bs + LLVMValInt base off -> ppPtr @sym (LLVMPointer base off) + LLVMValFloat _ v -> printSymExpr v + LLVMValStruct v -> encloseSep lbrace rbrace comma v'' + where v' = fmap (over _2 ppTermExpr) (V.toList v) + v'' = map (\(fld,doc) -> + group (pretty "base+" <> viaShow (fieldOffset fld) <+> equals <+> doc)) + v' + LLVMValArray _tp v -> encloseSep lbracket rbracket comma v' + where v' = ppTermExpr <$> V.toList v + +-- | Coerce an 'LLVMPtr' value into a memory-storable 'LLVMVal'. +ptrToPtrVal :: (1 <= w) => LLVMPtr sym w -> LLVMVal sym +ptrToPtrVal (LLVMPointer blk off) = LLVMValInt blk off + +zeroInt :: + IsSymInterface sym => + sym -> + Bytes -> + (forall w. (1 <= w) => Maybe (SymNat sym, SymBV sym w) -> IO a) -> + IO a +zeroInt sym bytes k + | Some w <- mkNatRepr (bytesToBits bytes) + , Just LeqProof <- isPosNat w + = do blk <- natLit sym 0 + bv <- bvLit sym w (BV.zero w) + k (Just (blk, bv)) +zeroInt _ _ k = k @1 Nothing + +-- | Pretty-print an 'LLVMVal'. +-- +-- This is parameterized over how to display pointers, see +-- 'ppLLVMValWithGlobals'. +ppLLVMVal :: + (Applicative f, IsExpr (SymExpr sym)) => + (forall w. SymNat sym -> SymBV sym w -> f (Maybe (Doc ann))) + {- ^ Printing of pointers -} -> + LLVMVal sym -> + f (Doc ann) +ppLLVMVal ppInt = + let typed doc tp = pretty doc <+> pretty ":" <+> viaShow tp + pp = ppLLVMVal ppInt + in + \case + (LLVMValZero tp) -> pure $ angles (typed "zero" tp) + (LLVMValUndef tp) -> pure $ angles (typed "undef" tp) + (LLVMValString bs) -> pure $ viaShow bs + (LLVMValInt blk w) -> fromMaybe otherDoc <$> ppInt blk w + where + otherDoc = + case asNat blk of + Just 0 -> + case (asBV w) of + (Just (BV.BV unsigned)) -> pretty $ unwords $ + [ "literal integer:" + , "unsigned value = " ++ show unsigned ++ "," + , unwords [ "signed value = " + , show (toSigned (bvWidth w) unsigned) ++ "," + ] + , "width = " ++ show (bvWidth w) + ] + Nothing -> pretty $ unwords $ + [ "symbolic integer: " + , "width = " ++ show (bvWidth w) + ] + Just n -> + case asBV w of + Just (BV.BV offset) -> pretty $ unwords $ + [ "concrete pointer:" + , "allocation = " ++ show n ++ "," + , "offset = " ++ show offset + ] + Nothing -> pretty $ unwords $ + [ "pointer with concrete allocation and symbolic offset:" + , "allocation = " ++ show n + ] + + Nothing -> + case asBV w of + Just (BV.BV offset) -> pretty $ + "pointer with concrete offset " ++ show offset + Nothing -> pretty "pointer with symbolic offset" + + (LLVMValFloat SingleSize _) -> pure $ pretty "symbolic float" + (LLVMValFloat DoubleSize _) -> pure $ pretty "symbolic double" + (LLVMValFloat X86_FP80Size _) -> pure $ pretty "symbolic long double" + (LLVMValStruct xs) -> encloseSep lbrace rbrace semi <$> traverse (pp . snd) (V.toList xs) + (LLVMValArray _ xs) -> list <$> traverse pp (V.toList xs) + +-- | Pretty-print an 'LLVMVal', but replace pointers to globals with the name of +-- the global when possible. Probably pretty slow on big structures. +ppLLVMValWithGlobals :: + forall sym ann. + (IsSymInterface sym) => + sym -> + Map Natural L.Symbol {- ^ c.f. 'memImplSymbolMap' -} -> + LLVMVal sym -> + Doc ann +ppLLVMValWithGlobals _sym symbolMap = runIdentity . ppLLVMVal ppInt + where + ppInt :: forall w. SymNat sym -> SymBV sym w -> Identity (Maybe (Doc ann)) + ppInt allocNum offset = + pure (ppSymbol <$> isGlobalPointer' @sym symbolMap (LLVMPointer allocNum offset)) + ppSymbol (L.Symbol symb) = pretty ('@' : symb) + +-- | This instance tries to make things as concrete as possible. +instance IsExpr (SymExpr sym) => Pretty (LLVMVal sym) where + pretty x = runIdentity $ ppLLVMVal (\_ _ -> Identity Nothing) x + +instance IsExpr (SymExpr sym) => Show (LLVMVal sym) where + show (LLVMValZero _tp) = "0" + show (LLVMValUndef tp) = "" + show (LLVMValString _) = "" + show (LLVMValInt blk w) + | Just 0 <- asNat blk = "" + | otherwise = "" + show (LLVMValFloat SingleSize _) = "" + show (LLVMValFloat DoubleSize _) = "" + show (LLVMValFloat X86_FP80Size _) = "" + show (LLVMValStruct xs) = + unwords $ [ "{" ] + ++ intersperse ", " (map (show . snd) $ V.toList xs) + ++ [ "}" ] + show (LLVMValArray _ xs) = + unwords $ [ "[" ] + ++ intersperse ", " (map show $ V.toList xs) + ++ [ "]" ] + +-- | An efficient n-way @and@: it quits early if it finds any concretely false +-- values, rather than chaining a bunch of 'andPred's. +allOf :: (IsExprBuilder sym) + => sym + -> [Pred sym] + -> IO (Pred sym) +allOf sym xs = + if and (mapMaybe asConstantPred xs) + then foldM (andPred sym) (truePred sym) xs + else pure (falsePred sym) + +{- +-- | An efficient n-way @or@: it quits early if it finds any concretely false +-- values, rather than chaining a bunch of 'orPred's. +oneOf :: (IsExprBuilder sym) + => sym + -> [Pred sym] + -> IO (Pred sym) +oneOf sym xs = + if or (mapMaybe asConstantPred xs) + then pure (truePred sym) + else foldM (orPred sym) (falsePred sym) xs +-} + +-- | Commute an applicative with Maybe +commuteMaybe :: Applicative n => Maybe (n a) -> n (Maybe a) +commuteMaybe (Just val) = Just <$> val +commuteMaybe Nothing = pure Nothing + +-- | This should be used with caution: it is very inefficient to expand zeroes, +-- especially to large data structures (e.g. long arrays). +zeroExpandLLVMVal :: (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) + => sym -> StorageType -> IO (LLVMVal sym) +zeroExpandLLVMVal sym (StorageType tpf _sz) = + case tpf of + Bitvector bytes -> + case mkNatRepr (bytesToBits bytes) of + Some (repr :: NatRepr w) -> + case testNatCases (knownNat @0) repr of + NatCaseLT (LeqProof :: LeqProof 1 w) -> + LLVMValInt <$> natLit sym 0 <*> bvLit sym repr (BV.zero repr) + NatCaseEQ -> panic "zeroExpandLLVMVal" ["Zero value inside Bytes"] + NatCaseGT (LeqProof :: LeqProof (w + 1) 0) -> + panic "zeroExpandLLVMVal" ["Impossible: (w + 1) LLVMValFloat SingleSize <$> iFloatPZero sym SingleFloatRepr + Double -> LLVMValFloat DoubleSize <$> iFloatPZero sym DoubleFloatRepr + X86_FP80 -> LLVMValFloat X86_FP80Size <$> iFloatPZero sym X86_80FloatRepr + Array n ty + | toInteger n <= toInteger (maxBound :: Int) -> + LLVMValArray ty . V.replicate (fromIntegral n :: Int) <$> + zeroExpandLLVMVal sym ty + | otherwise -> panic "zeroExpandLLVMVal" ["Array length too large", show n] + Struct vec -> + LLVMValStruct <$> + V.zipWithM (\f t -> (f,) <$> zeroExpandLLVMVal sym t) vec (fmap (view fieldVal) vec) + +-- | A special case for comparing values to the distinguished zero value. +-- +-- Should be faster than using 'testEqual' with 'zeroExpandLLVMVal' for compound +-- values, because we 'traverse' subcomponents of vectors and structs, quitting +-- early on a constantly false answer or 'LLVMValUndef'. +-- +-- Returns 'Nothing' for 'LLVMValUndef'. +isZero :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) + => sym -> LLVMVal sym -> IO (Maybe (Pred sym)) +isZero sym v = + case v of + LLVMValStruct fs -> areZero' (fmap snd fs) + LLVMValArray _ vs -> areZero' vs + LLVMValString bs -> pure $ Just $ backendPred sym $ not $ isJust $ BS.find (/= 0) bs + LLVMValZero _ -> pure (Just $ truePred sym) + LLVMValUndef _ -> pure Nothing + _ -> + -- For atomic types, we simply expand and compare. + testEqual sym v =<< zeroExpandLLVMVal sym (llvmValStorableType v) + where + areZero :: Traversable t => t (LLVMVal sym) -> IO (Maybe (t (Pred sym))) + areZero = fmap sequence . traverse (isZero sym) + areZero' :: Traversable t => t (LLVMVal sym) -> IO (Maybe (Pred sym)) + areZero' vs = + -- This could probably be simplified with a well-placed =<<... + join $ fmap commuteMaybe $ fmap (fmap (allOf sym . toList)) $ areZero vs + +-- | A predicate denoting the equality of two LLVMVals. +-- +-- Returns 'Nothing' in the event that one of the values contains 'LLVMValUndef'. +testEqual :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) + => sym -> LLVMVal sym -> LLVMVal sym -> IO (Maybe (Pred sym)) +testEqual sym v1 v2 = + case (v1, v2) of + (LLVMValInt blk1 off1, LLVMValInt blk2 off2) -> + case testEquality (bvWidth off1) (bvWidth off2) of + Nothing -> false + Just Refl -> + natEq sym blk1 blk2 >>= \p1 -> + Just <$> (andPred sym p1 =<< bvEq sym off1 off2) + (LLVMValFloat (sz1 :: FloatSize fi1) flt1, LLVMValFloat sz2 flt2) -> + case testEquality sz1 sz2 of + Nothing -> false + Just Refl -> Just <$> iFloatEq @_ @fi1 sym flt1 flt2 + (LLVMValArray tp1 vec1, LLVMValArray tp2 vec2) -> + andAlso (tp1 == tp2 && V.length vec1 == V.length vec2) (allEqual vec1 vec2) + (LLVMValStruct vec1, LLVMValStruct vec2) -> + let (si1, si2) = (fmap fst vec1, fmap fst vec2) + (fd1, fd2) = (fmap snd vec1, fmap snd vec2) + in andAlso (V.length vec1 == V.length vec2 && V.and (V.zipWith (==) si1 si2)) + (allEqual fd1 fd2) + + (LLVMValString bs1, LLVMValString bs2) -> if bs1 == bs2 then true else false + (LLVMValString bs, v@LLVMValArray{}) -> + do bsv <- explodeStringValue sym bs + testEqual sym bsv v + (v@LLVMValArray{}, LLVMValString bs) -> + do bsv <- explodeStringValue sym bs + testEqual sym v bsv + + (LLVMValZero tp1, LLVMValZero tp2) -> if tp1 == tp2 then true else false + (LLVMValZero tp, other) -> compareZero tp other + (other, LLVMValZero tp) -> compareZero tp other + (LLVMValUndef _, _) -> pure Nothing + (_, LLVMValUndef _) -> pure Nothing + (_, _) -> false -- type mismatch + + where true = pure (Just $ truePred sym) + false = pure (Just $ falsePred sym) + + andAlso b x = if b then x else false + + allEqual vs1 vs2 = + foldM (\x y -> commuteMaybe (andPred sym <$> x <*> y)) (Just $ truePred sym) =<< + V.zipWithM (testEqual sym) vs1 vs2 + + -- This is probably inefficient: + compareZero tp other = + andAlso (llvmValStorableType other == tp) $ isZero sym other + + +-- | Turns a bytestring into an explicit array of bytes +explodeStringValue :: forall sym. (IsExprBuilder sym, IsInterpretedFloatExprBuilder sym) => + sym -> ByteString -> IO (LLVMVal sym) +explodeStringValue sym bs = + do blk <- natLit sym 0 + vs <- V.generateM (BS.length bs) + (\i -> LLVMValInt blk <$> bvLit sym (knownNat @8) (BV.word8 (BS.index bs i))) + pure (LLVMValArray (bitvectorType (Bytes 1)) vs) diff --git a/src/Lang/Crucible/LLVM/MemType.hs b/src/Lang/Crucible/LLVM/MemType.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/MemType.hs @@ -0,0 +1,397 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.MemType +-- Description : Basic datatypes for describing LLVM types +-- Copyright : (c) Galois, Inc 2011-2013 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.MemType + ( -- * Type information. + SymType(..) + , MemType(..) + , memTypeAlign + , memTypeSize + , ppSymType + , ppMemType + , memTypeBitwidth + , isPointerMemType + -- ** Function type information. + , FunDecl(..) + , RetType + , voidFunDecl + , funDecl + , varArgsFunDecl + , ppFunDecl + , ppRetType + -- ** Struct type information. + , StructInfo + , siIsPacked + , mkStructInfo + , siFieldCount + , FieldInfo + , fiOffset + , fiType + , fiPadding + , siFieldInfo + , siFieldTypes + , siFieldOffset + , siFields + , siIndexOfOffset + -- ** Common memory types. + , i1, i8, i16, i32, i64 + , i8p, i16p, i32p, i64p + -- * Re-exports + , L.Ident(..) + , ppIdent + ) where + +import Control.Lens +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Natural +import qualified Text.LLVM as L +import Prettyprinter + +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.PrettyPrint hiding (ppIdent, ppType) +import Lang.Crucible.Panic ( panic ) + +-- | Performs a binary search on a range of ints. +binarySearch :: (Int -> Ordering) + -> Int -- ^ Lower bound (included in range) + -> Int -- ^ Upper bound (excluded from range) + -> Maybe Int +binarySearch f = go + where go l h | l == h = Nothing + | otherwise = case f i of + -- Index is less than one f is searching for + LT -> go (i+1) h + EQ -> Just i + -- Index is greater than one f is searching for. + GT -> go l i + where i = l + (h - l) `div` 2 + +ppIdent :: L.Ident -> Doc ann +ppIdent = viaShow . LPP.ppIdent +-- TODO: update if llvm-pretty switches to prettyprinter + +-- | LLVM types supported by symbolic simulator. +data SymType + = MemType MemType + | Alias L.Ident + | FunType FunDecl + | VoidType + -- | A type that LLVM does not know the structure of such as + -- a struct that is declared, but not defined. + | OpaqueType + -- | A type not supported by the symbolic simulator. + | UnsupportedType L.Type + deriving (Eq, Ord) + +instance Show SymType where + show = show . ppSymType + +instance Pretty SymType where + pretty = ppSymType + +-- | Pretty-print a 'SymType'. +ppSymType :: SymType -> Doc ann +ppSymType (MemType tp) = ppMemType tp +ppSymType (Alias i) = ppIdent i +ppSymType (FunType d) = ppFunDecl d +ppSymType VoidType = pretty "void" +ppSymType OpaqueType = pretty "opaque" +ppSymType (UnsupportedType tp) = viaShow (LPP.ppType tp) +-- TODO: update if llvm-pretty switches to prettyprinter + +-- | LLVM types supported by simulator with a defined size and alignment. +data MemType + = IntType Natural + | PtrType SymType + -- ^ A pointer with an explicit pointee type, corresponding to LLVM's + -- 'L.PtrTo'. + | PtrOpaqueType + -- ^ An opaque pointer type, corresponding to LLVM's 'L.PtrOpaque'. + | FloatType + | DoubleType + | X86_FP80Type + | ArrayType Natural MemType + | VecType Natural MemType + | StructType StructInfo + | MetadataType + deriving (Eq, Ord) + +instance Show MemType where + show = show . ppMemType + +instance Pretty MemType where + pretty = ppMemType + +-- | Pretty-print a 'MemType'. +ppMemType :: MemType -> Doc ann +ppMemType mtp = + case mtp of + IntType w -> ppIntType w + FloatType -> pretty "float" + DoubleType -> pretty "double" + X86_FP80Type -> pretty "long double" + PtrType tp -> ppPtrType (ppSymType tp) + PtrOpaqueType -> pretty "ptr" + ArrayType n tp -> ppArrayType n (ppMemType tp) + VecType n tp -> ppVectorType n (ppMemType tp) + StructType si -> ppStructInfo si + MetadataType -> pretty "metadata" + +-- | 1-bit integer type. +i1 :: MemType +i1 = IntType 1 + +-- | 8-bit integer type. +i8 :: MemType +i8 = IntType 8 + +-- | 16-bit integer type. +i16 :: MemType +i16 = IntType 16 + +-- | 32-bit integer type. +i32 :: MemType +i32 = IntType 32 + +-- | 64-bit integer type. +i64 :: MemType +i64 = IntType 64 + +-- | Pointer to 8-bit integer. +i8p :: MemType +i8p = PtrType (MemType i8) + +-- | Pointer to 16-bit integer. +i16p :: MemType +i16p = PtrType (MemType i16) + +-- | Pointer to 32-bit integer. +i32p :: MemType +i32p = PtrType (MemType i32) + +-- | Pointer to 64-bit integer. +i64p :: MemType +i64p = PtrType (MemType i64) + +-- | An LLVM function type. +data FunDecl = FunDecl { fdRetType :: !RetType + , fdArgTypes :: ![MemType] + , fdVarArgs :: !Bool + } + deriving (Eq, Ord) + +-- | Return the number of bits that represent the given memtype, which +-- must be either integer types, floating point types or vectors of +-- the same. +memTypeBitwidth :: MemType -> Maybe Natural +memTypeBitwidth (IntType w) = Just w +memTypeBitwidth FloatType = Just 32 +memTypeBitwidth DoubleType = Just 64 +memTypeBitwidth X86_FP80Type = Just 80 +memTypeBitwidth (VecType n tp) = (fromIntegral n *) <$> memTypeBitwidth tp +memTypeBitwidth _ = Nothing + +-- | Returns 'True' if this is a pointer type. +isPointerMemType :: MemType -> Bool +isPointerMemType (PtrType _) = True +isPointerMemType PtrOpaqueType = True +isPointerMemType _ = False + +-- | Return type if any. +type RetType = Maybe MemType + +-- | Declare function that returns void. +voidFunDecl :: [MemType] -> FunDecl +voidFunDecl tps = FunDecl { fdRetType = Nothing + , fdArgTypes = tps + , fdVarArgs = False + } + +-- | Declare function that returns a value. +funDecl :: MemType -> [MemType] -> FunDecl +funDecl rtp tps = FunDecl { fdRetType = Just rtp + , fdArgTypes = tps + , fdVarArgs = False + } + +-- | Declare function that returns a value. +varArgsFunDecl :: MemType -> [MemType] -> FunDecl +varArgsFunDecl rtp tps = FunDecl { fdRetType = Just rtp + , fdArgTypes = tps + , fdVarArgs = True + } + +-- | Pretty-print a function type. +ppFunDecl :: FunDecl -> Doc ann +ppFunDecl (FunDecl rtp args va) = rdoc <> parens (commas (fmap ppMemType args ++ vad)) + where rdoc = maybe (pretty "void") ppMemType rtp + vad = if va then [pretty "..."] else [] + +-- | Pretty print a return type. +ppRetType :: RetType -> Doc ann +ppRetType = maybe (pretty "void") ppMemType + +-- | Returns size of a 'MemType' in bytes. +memTypeSize :: DataLayout -> MemType -> Bytes +memTypeSize dl mtp = + case mtp of + IntType w -> intWidthSize w + FloatType -> 4 + DoubleType -> 8 + X86_FP80Type -> 10 + PtrType{} -> dl ^. ptrSize + PtrOpaqueType{} -> dl ^. ptrSize + ArrayType n tp -> natBytesMul n (memTypeSize dl tp) + VecType n tp -> natBytesMul n (memTypeSize dl tp) + StructType si -> structSize si + MetadataType -> 0 + +memTypeSizeInBits :: DataLayout -> MemType -> Natural +memTypeSizeInBits dl tp = bytesToBits (memTypeSize dl tp) + +-- | Returns ABI byte alignment constraint in bytes. +memTypeAlign :: DataLayout -> MemType -> Alignment +memTypeAlign dl mtp = + case mtp of + IntType w -> integerAlignment dl (fromIntegral w) + FloatType -> case floatAlignment dl 32 of + Just a -> a + Nothing -> panic "crucible-llvm:memTypeAlign.float32" + [ "Invalid 32-bit float alignment from datalayout" ] + DoubleType -> case floatAlignment dl 64 of + Just a -> a + Nothing -> panic "crucible-llvm:memTypeAlign.float64" + [ "Invalid 64-bit float alignment from datalayout" ] + X86_FP80Type -> case floatAlignment dl 80 of + Just a -> a + Nothing -> panic "crucible-llvm:memTypeAlign.float80" + [ "Invalid 80-bit float alignment from datalayout" ] + PtrType{} -> dl ^. ptrAlign + PtrOpaqueType{} -> dl ^. ptrAlign + ArrayType _ tp -> memTypeAlign dl tp + VecType _n _tp -> vectorAlignment dl (memTypeSizeInBits dl mtp) + StructType si -> structAlign si + MetadataType -> noAlignment + +-- | Information about size, alignment, and fields of a struct. +data StructInfo = StructInfo + { siIsPacked :: !Bool + , structSize :: !Bytes -- ^ Size in bytes. + , structAlign :: !Alignment + , siFields :: !(V.Vector FieldInfo) + } + deriving (Eq, Ord, Show) + +data FieldInfo = FieldInfo + { fiOffset :: !Offset -- ^ Byte offset of field relative to start of struct. + , fiType :: !MemType -- ^ Type of field. + , fiPadding :: !Bytes -- ^ Number of bytes of padding at end of field. + } + deriving (Eq, Ord, Show) + + +-- | Constructs a function for obtaining target-specific size/alignment +-- information about structs. The function produced corresponds to the +-- @StructLayout@ object constructor in TargetData.cpp. +mkStructInfo :: DataLayout + -> Bool -- ^ @True@ = packed, @False@ = unpacked + -> [MemType] -- ^ Field types + -> StructInfo +mkStructInfo dl packed tps0 = go [] 0 a0 tps0 + where a0 | packed = noAlignment + | otherwise = nextAlign noAlignment tps0 `max` aggregateAlignment dl + -- Padding after each field depends on the alignment of the + -- type of the next field, if there is one. Padding after the + -- last field depends on the alignment of the whole struct + -- (i.e. the maximum alignment of any field). Alignment value + -- of n means to align on 2^n byte boundaries. + nextAlign :: Alignment -> [MemType] -> Alignment + nextAlign _ _ | packed = noAlignment + nextAlign maxAlign [] = maxAlign + nextAlign _ (tp:_) = memTypeAlign dl tp + + -- Process fields + go :: [FieldInfo] -- ^ Fields so far in reverse order. + -> Bytes -- ^ Total size so far (aligned to next element) + -> Alignment -- ^ Maximum alignment so far + -> [MemType] -- ^ Field types to process + -> StructInfo + + go flds sz maxAlign (tp:tpl) = + go (fi:flds) sz' (max maxAlign fieldAlign) tpl + + where + fi = FieldInfo + { fiOffset = sz + , fiType = tp + , fiPadding = sz' - e + } + + -- End of field for tp + e = sz + memTypeSize dl tp + + -- Alignment of next field + fieldAlign = nextAlign maxAlign tpl + + -- Size of field at alignment for next thing. + sz' = padToAlignment e fieldAlign + + go flds sz maxAlign [] = + StructInfo { siIsPacked = packed + , structSize = sz + , structAlign = maxAlign + , siFields = V.fromList (reverse flds) + } + +-- | The types of a struct type's fields. +siFieldTypes :: StructInfo -> Vector MemType +siFieldTypes si = fiType <$> siFields si + +-- | Number of fields in a struct type. +siFieldCount :: StructInfo -> Int +siFieldCount = V.length . siFields + +-- | Returns information for field with given index, if it is defined. +siFieldInfo :: StructInfo -> Int -> Maybe FieldInfo +siFieldInfo si i = siFields si V.!? i + +-- | Returns offset of field with given index, if it is defined. +siFieldOffset :: StructInfo -> Int -> Maybe Offset +siFieldOffset si i = fiOffset <$> siFieldInfo si i + +-- | Returns index of field at the given byte offset (if any). +siIndexOfOffset :: StructInfo -> Offset -> Maybe Int +siIndexOfOffset si o = binarySearch f 0 (V.length flds) + where flds = siFields si + f i | e <= o = LT -- Index too low if field ends before offset. + | o < s = GT -- Index too high if field starts after offset. + | otherwise = EQ + where s = fiOffset (flds V.! i) + e | i+1 == V.length flds = structSize si + | otherwise = fiOffset (flds V.! i) + +commas :: [Doc ann] -> Doc ann +commas = hsep . punctuate (pretty ',') + +structBraces :: Bool -> Doc ann -> Doc ann +structBraces False b = pretty '{' <+> b <+> pretty '}' +structBraces True b = pretty "<{" <+> b <+> pretty "}>" + +-- | Pretty print struct info. +ppStructInfo :: StructInfo -> Doc ann +ppStructInfo si = structBraces (siIsPacked si) $ commas (V.toList fields) + where fields = ppMemType <$> siFieldTypes si diff --git a/src/Lang/Crucible/LLVM/PrettyPrint.hs b/src/Lang/Crucible/LLVM/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/PrettyPrint.hs @@ -0,0 +1,97 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.PrettyPrint +-- Description : Printing utilties for LLVM +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module defines several functions whose names clash with functions +-- offered elsewhere in @llvm-pretty@ (e.g., "Text.LLVM.PP") and in +-- @crucible-llvm@ (e.g., "Lang.Crucible.LLVM.MemModel.MemLog"). For this +-- reason, it is recommended to import this module qualified. +------------------------------------------------------------------------ + +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RankNTypes #-} +module Lang.Crucible.LLVM.PrettyPrint + ( commaSepList + , ppIntType + , ppPtrType + , ppArrayType + , ppVectorType + , ppIntVector + + -- * @llvm-pretty@ printing with the latest LLVM version + , ppLLVMLatest + , ppDeclare + , ppIdent + , ppSymbol + , ppType + , ppValue + ) where + +import Numeric.Natural +import Prettyprinter +import qualified Text.PrettyPrint.HughesPJ as HPJ + +import qualified Text.LLVM.AST as L +import qualified Text.LLVM.PP as L + +-- | Print list of documents separated by commas and spaces. +commaSepList :: [Doc ann] -> Doc ann +commaSepList l = hcat (punctuate (comma <> pretty ' ') l) + +-- | Pretty print int type with width. +ppIntType :: Integral a => a -> Doc ann +ppIntType i = pretty 'i' <> pretty (toInteger i) + +-- | Pretty print pointer type. +ppPtrType :: Doc ann -> Doc ann +ppPtrType tp = tp <> pretty '*' + +ppArrayType :: Natural -> Doc ann -> Doc ann +ppArrayType n e = brackets (pretty (toInteger n) <+> pretty 'x' <+> e) + +ppVectorType :: Natural -> Doc ann -> Doc ann +ppVectorType n e = angles (pretty (toInteger n) <+> pretty 'x' <+> e) + +ppIntVector :: Integral a => Natural -> a -> Doc ann +ppIntVector n w = ppVectorType n (ppIntType w) + +-- | Pretty-print an LLVM-related AST in accordance with the latest LLVM version +-- that @llvm-pretty@ currently supports (i.e., the value of 'L.llvmVlatest'.) +-- +-- Note that we are mainly using the @llvm-pretty@ printer in @crucible-llvm@ +-- for the sake of defining 'Show' instances and creating error messages, not +-- for creating machine-readable LLVM code. As a result, it doesn't particularly +-- matter which LLVM version we use, as any version-specific differences in +-- pretty-printer output won't be that impactful. +ppLLVMLatest :: ((?config :: L.Config) => a) -> a +ppLLVMLatest = L.withConfig (L.Config { L.cfgVer = L.llvmVlatest }) + +-- | Invoke 'L.ppDeclare' in accordance with the latest LLVM version that +-- @llvm-pretty@ supports. +ppDeclare :: L.Declare -> HPJ.Doc +ppDeclare = ppLLVMLatest L.ppDeclare + +-- | Invoke 'L.ppIdent' in accordance with the latest LLVM version that +-- @llvm-pretty@ supports. +ppIdent :: L.Ident -> HPJ.Doc +ppIdent = ppLLVMLatest L.ppIdent + +-- | Invoke 'L.ppSymbol' in accordance with the latest LLVM version that +-- @llvm-pretty@ supports. +ppSymbol :: L.Symbol -> HPJ.Doc +ppSymbol = ppLLVMLatest L.ppSymbol + +-- | Invoke 'L.ppType' in accordance with the latest LLVM version that +-- @llvm-pretty@ supports. +ppType :: L.Type -> HPJ.Doc +ppType = ppLLVMLatest L.ppType + +-- | Invoke 'L.ppValue' in accordance with the latest LLVM version that +-- @llvm-pretty@ supports. +ppValue :: L.Value -> HPJ.Doc +ppValue = ppLLVMLatest L.ppValue diff --git a/src/Lang/Crucible/LLVM/Printf.hs b/src/Lang/Crucible/LLVM/Printf.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Printf.hs @@ -0,0 +1,475 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Printf +-- Description : Interpretation of 'printf' style conversion codes +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- A model of C's @printf@ function. This does not entirely conform to the C +-- standard's specification of @printf@; see @doc/limitations.md@ for the +-- specifics. +-- +------------------------------------------------------------------------ + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module Lang.Crucible.LLVM.Printf +( PrintfFlag(..) +, PrintfLengthModifier(..) +, Case(..) +, IntFormat(..) +, FloatFormat(..) +, PrintfConversionType(..) +, PrintfDirective(..) +, parseDirectives +, ConversionDirective(..) +, PrintfOperations(..) +, executeDirectives +, formatInteger +, formatRational +) where + +import Data.Char (toUpper) +import qualified Numeric as N +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 hiding (take) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import qualified GHC.Stack as GHC + +data PrintfFlag + = PrintfAlternateForm -- # + | PrintfZeroPadding -- 0 + | PrintfNegativeWidth -- - + | PrintfPosSpace -- ' ' + | PrintfPosPlus -- + + | PrintfThousandsSep -- ' + deriving (Eq,Ord,Show) + +data PrintfLengthModifier + = Len_Byte -- hh + | Len_Short -- h + | Len_Long -- l + | Len_LongLong -- ll + | Len_LongDouble -- L + | Len_IntMax -- j + | Len_PtrDiff -- t + | Len_Sizet -- z + | Len_NoMod -- <> + deriving (Eq,Ord,Show) + +data Case + = UpperCase + | LowerCase + deriving (Eq,Ord,Show) + +data IntFormat + = IntFormat_SignedDecimal -- i,d + | IntFormat_UnsignedDecimal -- u + | IntFormat_Octal -- o + | IntFormat_Hex Case -- x,X + deriving (Eq,Ord,Show) + +signedIntFormat :: IntFormat -> Bool +signedIntFormat IntFormat_SignedDecimal = True +signedIntFormat _ = False + +data FloatFormat + = FloatFormat_Scientific Case -- e,E + | FloatFormat_Standard Case -- f,F + | FloatFormat_Auto Case -- g,G + | FloatFormat_Hex Case -- a,A + deriving (Eq,Ord,Show) + +data PrintfConversionType + = Conversion_Integer IntFormat + | Conversion_Floating FloatFormat + | Conversion_Char -- c + | Conversion_String -- s + | Conversion_Pointer -- p + | Conversion_CountChars -- n + deriving (Eq,Ord,Show) + +data PrintfDirective + = StringDirective BS.ByteString + | ConversionDirective ConversionDirective + deriving (Eq,Ord,Show) + +data ConversionDirective = Conversion + { printfAccessField :: Maybe Int + , printfFlags :: Set PrintfFlag + , printfMinWidth :: Int + , printfPrecision :: Maybe Int + , printfLengthMod :: PrintfLengthModifier + , printfType :: PrintfConversionType + } + deriving (Eq,Ord,Show) + + +data PrintfOperations m + = PrintfOperations + { printfGetInteger :: Int -- Field number + -> Bool -- is Signed? + -> PrintfLengthModifier + -> m (Maybe Integer) + , printfGetFloat :: Int -- FieldNumber + -> PrintfLengthModifier + -> m (Maybe Rational) + , printfGetPointer :: Int -- FieldNumber + -> m String + , printfGetString :: Int -- FieldNumber + -> Maybe Int -- Number of chars to read; if Nothing, read until null terminator + -> m [Word8] + , printfSetInteger :: Int -- FieldNumber + -> PrintfLengthModifier + -> Int -- value to set + -> m () + + , printfUnsupported :: !(forall a. GHC.HasCallStack => String -> m a) + } + +formatInteger + :: Maybe Integer + -> IntFormat + -> Int -- min width + -> Maybe Int -- precision + -> Set PrintfFlag + -> String +formatInteger mi fmt minwidth prec flags = + case mi of + Nothing -> + let n = max 4 (max minwidth (fromMaybe 0 prec)) + in replicate n '?' + Just i -> do + case fmt of + IntFormat_SignedDecimal -> + formatSignedDec i minwidth prec flags + IntFormat_UnsignedDecimal -> + formatUnsignedDec i minwidth prec flags + IntFormat_Octal -> + formatOctal i minwidth prec flags + IntFormat_Hex c -> + formatHex i c minwidth prec flags + +insertThousands :: Char -> String -> String +insertThousands sep = reverse . go . reverse + where + go (a:b:c:xs@(_:_)) = a:b:c:sep:go xs + go xs = xs + + +addLeadingZeros :: + Maybe Int -> -- precision + String -> + String +addLeadingZeros Nothing digits = digits +addLeadingZeros (Just p) digits = + let n = max 0 (p - length digits) in + replicate n '0' ++ digits + +formatSignedDec + :: Integer -- value to format + -> Int -- minwidth + -> Maybe Int -- precision + -> Set PrintfFlag + -> String +formatSignedDec i minwidth prec flags = do + let sgn = if | i < 0 -> "-" + | Set.member PrintfPosPlus flags -> "+" + | Set.member PrintfPosSpace flags -> " " + | otherwise -> "" + let digits = N.showInt (abs i) [] + let precdigits = addLeadingZeros prec digits + let sepdigits = if Set.member PrintfThousandsSep flags then + insertThousands ',' precdigits -- FIXME, get thousands separator from somewhere? + else + precdigits + let pad = max 0 (minwidth - length sepdigits - length sgn) + if | Set.member PrintfNegativeWidth flags -> + sgn ++ sepdigits ++ replicate pad ' ' + | Set.member PrintfZeroPadding flags && prec == Nothing -> + -- FIXME? this interacts poorly with the thousands seperation flag... + sgn ++ replicate pad '0' ++ sepdigits + | otherwise -> + replicate pad ' ' ++ sgn ++ sepdigits + +formatUnsignedDec + :: Integer -- value to format + -> Int -- minwidth + -> Maybe Int -- precision + -> Set PrintfFlag + -> String +formatUnsignedDec i minwidth prec flags = do + let digits = N.showInt (abs i) [] + let precdigits = addLeadingZeros prec digits + let sepdigits = if Set.member PrintfThousandsSep flags then + insertThousands ',' precdigits -- FIXME, get thousands separator from somewhere? + else + precdigits + let pad = max 0 (minwidth - length sepdigits) + if | Set.member PrintfNegativeWidth flags -> + sepdigits ++ replicate pad ' ' + | Set.member PrintfZeroPadding flags && prec == Nothing -> + -- FIXME? this interacts poorly with the thousands seperation flag... + replicate pad '0' ++ sepdigits + | otherwise -> + replicate pad ' ' ++ sepdigits + +formatOctal + :: Integer -- value to format + -> Int -- minwidth + -> Maybe Int -- precision + -> Set PrintfFlag + -> String +formatOctal i minwidth prec flags = do + let digits = N.showOct (abs i) [] + let precdigits = addLeadingZeros prec digits + let altdigits = if Set.member PrintfAlternateForm flags && head precdigits /= '0' then + '0':precdigits + else + precdigits + let pad = max 0 (minwidth - length altdigits) + if | Set.member PrintfNegativeWidth flags -> + altdigits ++ replicate pad ' ' + | Set.member PrintfZeroPadding flags && prec == Nothing -> + replicate pad '0' ++ altdigits + | otherwise -> + replicate pad ' ' ++ altdigits + +formatHex + :: Integer -- value to format + -> Case -- upper or lower case + -> Int -- minwidth + -> Maybe Int -- precision + -> Set PrintfFlag + -> String +formatHex i c minwidth prec flags = do + let digits = N.showHex (abs i) [] + let precdigits = addLeadingZeros prec digits + -- Why only add "0x" when i is non-zero? I have no idea, + -- that's just what the docs say... + let altstring = if Set.member PrintfAlternateForm flags && i /= 0 then + "0x" + else + "" + let pad = max 0 (minwidth - length precdigits - length altstring) + let padded = if | Set.member PrintfNegativeWidth flags -> + altstring ++ precdigits ++ replicate pad ' ' + | Set.member PrintfZeroPadding flags && prec == Nothing -> + altstring ++ replicate pad '0' ++ precdigits + | otherwise -> + replicate pad ' ' ++ altstring ++ precdigits + case c of + UpperCase -> map toUpper padded + LowerCase -> padded + + +formatRational + :: Maybe Rational + -> FloatFormat + -> Int -- min width + -> Maybe Int -- precision + -> Set PrintfFlag + -> Either String String -- ^ Left indicates an error, right is OK +formatRational mr fmt minwidth prec flags = + case mr of + Nothing -> + let n = max 4 (min minwidth (fromMaybe 0 prec)) + in return (replicate n '?') + Just r -> + -- FIXME, we ignore the thousands flag... + do let toCase c x = case c of + UpperCase -> map toUpper x + LowerCase -> x + let sgn = if | r < 0 -> "-" + | Set.member PrintfPosPlus flags -> "+" + | Set.member PrintfPosSpace flags -> " " + | otherwise -> "" + let dbl = N.fromRat (abs r) :: Double + let prec' = case prec of Nothing -> Just 6; _ -> prec + str <- case fmt of + FloatFormat_Scientific c -> + return $ toCase c $ N.showEFloat prec' dbl [] + FloatFormat_Standard c -> + return $ toCase c $ + if Set.member PrintfAlternateForm flags + then N.showFFloatAlt prec' dbl [] + else N.showFFloat prec' dbl [] + FloatFormat_Auto c -> + return $ toCase c $ + if Set.member PrintfAlternateForm flags + then N.showGFloatAlt prec' dbl [] + else N.showGFloat prec' dbl [] + FloatFormat_Hex _c -> + -- FIXME, could probably implement this using N.floatToDigits... + Left "'a' and 'A' conversion codes not currently supported" + let pad = max 0 (minwidth - length str - length sgn) + return $ + if | Set.member PrintfNegativeWidth flags -> + sgn ++ str ++ replicate pad ' ' + | Set.member PrintfZeroPadding flags -> + sgn ++ replicate pad '0' ++ str + | otherwise -> + replicate pad ' ' ++ sgn ++ str + +-- | Given a list of 'PrintfDirective's, compute the resulting 'BS.ByteString' +-- and its length. +-- +-- We make an effort not to assume a particular text encoding for the +-- 'BS.ByteString' that this returns. Some parts of the implementation do use +-- functionality from "Data.ByteString.Char8", which is limited to the subset +-- of Unicode covered by code points 0-255. We believe these uses are justified, +-- however, and we have left comments explaining the reasoning behind each use. +executeDirectives :: forall m. Monad m + => PrintfOperations m + -> [PrintfDirective] + -> m (BS.ByteString, Int) +executeDirectives ops = go id 0 0 + where + go :: (BS.ByteString -> BS.ByteString) -> Int -> Int -> [PrintfDirective] -> m (BS.ByteString, Int) + go fstr !len !_fld [] = return (fstr BS.empty, len) + go fstr !len !fld ((StringDirective s):xs) = do + let len' = len + BS.length s + let fstr' = fstr . BS.append s + go fstr' len' fld xs + go fstr !len !fld (ConversionDirective d:xs) = + let fld' = fromMaybe (fld+1) (printfAccessField d) in + case printfType d of + Conversion_Integer fmt -> do + let sgn = signedIntFormat fmt + i <- printfGetInteger ops fld' sgn (printfLengthMod d) + -- The use of BSC.pack is fine here, as the output of formatInteger + -- consists solely of ASCII characters. + let istr = BSC.pack $ formatInteger i fmt (printfMinWidth d) (printfPrecision d) (printfFlags d) + let len' = len + BS.length istr + let fstr' = fstr . BS.append istr + go fstr' len' fld' xs + Conversion_Floating fmt -> do + r <- printfGetFloat ops fld' (printfLengthMod d) + -- The use of BSC.pack is fine here, as the output of formatRational + -- consists solely of ASCII characters. + rstr <- BSC.pack <$> + case formatRational r fmt + (printfMinWidth d) + (printfPrecision d) + (printfFlags d) of + Left err -> printfUnsupported ops err + Right a -> return a + let len' = len + BS.length rstr + let fstr' = fstr . BS.append rstr + go fstr' len' fld' xs + Conversion_String -> do + s <- BS.pack <$> printfGetString ops fld' (printfPrecision d) + let len' = len + BS.length s + let fstr' = fstr . BS.append s + go fstr' len' fld' xs + Conversion_Char -> do + let sgn = False -- unsigned + i <- printfGetInteger ops fld' sgn Len_NoMod + let c :: Char = maybe '?' (toEnum . fromInteger) i + let len' = len + 1 + -- Note the use of BSC.cons here: this assumes on the assumption + -- that C strings are arrays of 1-byte characters. + let fstr' = fstr . BSC.cons c + go fstr' len' fld' xs + Conversion_Pointer -> do + -- Note the use of BSC.pack here: this assumes that the output of + -- printfGetPointer uses solely ASCII characters. For crux-llvm's + -- printf override, this is always the case, as pointers are + -- pretty-printed using the ppPtr function, which satisfies this + -- criterion. + pstr <- BSC.pack <$> printfGetPointer ops fld' + let len' = len + BS.length pstr + let fstr' = fstr . BS.append pstr + go fstr' len' fld' xs + Conversion_CountChars -> do + printfSetInteger ops fld' (printfLengthMod d) len + go fstr len fld' xs + +parseDirectives :: [Word8] -> Either String [PrintfDirective] +parseDirectives xs = + parseOnly (parseFormatString <* endOfInput) (BS.pack xs) + +parseFormatString :: Parser [PrintfDirective] +parseFormatString = many $ choice + [ StringDirective <$> takeWhile1 (/= '%') + , string "%%" >> return (StringDirective "%") + , parseConversion + ] + +parseConversion :: Parser PrintfDirective +parseConversion = do + _ <- char '%' + field <- option Nothing (Just <$> + do d <- decimal + _ <- char '$' + return d) + flags <- parseFlags Set.empty + width <- option 0 decimal + prec <- option Nothing (char '.' >> (Just <$> decimal)) + len <- parseLenModifier + typ <- parseConversionType + return $ ConversionDirective $ Conversion + { printfAccessField = field + , printfFlags = flags + , printfMinWidth = width + , printfPrecision = prec + , printfLengthMod = len + , printfType = typ + } + +parseFlags :: Set PrintfFlag -> Parser (Set PrintfFlag) +parseFlags fs = choice + [ char '#' >> parseFlags (Set.insert PrintfAlternateForm fs) + , char '0' >> parseFlags (Set.insert PrintfZeroPadding fs) + , char '-' >> parseFlags (Set.insert PrintfNegativeWidth fs) + , char ' ' >> parseFlags (Set.insert PrintfPosSpace fs) + , char '+' >> parseFlags (Set.insert PrintfPosPlus fs) + , char '\'' >> parseFlags (Set.insert PrintfThousandsSep fs) + , return fs + ] + +parseLenModifier :: Parser PrintfLengthModifier +parseLenModifier = choice + [ string "hh" >> return Len_Byte + , string "h" >> return Len_Short + , string "ll" >> return Len_LongLong + , string "L" >> return Len_LongDouble + , string "l" >> return Len_Long + , string "j" >> return Len_IntMax + , string "t" >> return Len_PtrDiff + , string "z" >> return Len_Sizet + , return Len_NoMod + ] + +parseConversionType :: Parser PrintfConversionType +parseConversionType = choice + [ char 'd' >> return (Conversion_Integer IntFormat_SignedDecimal) + , char 'i' >> return (Conversion_Integer IntFormat_SignedDecimal) + , char 'u' >> return (Conversion_Integer IntFormat_UnsignedDecimal) + , char 'o' >> return (Conversion_Integer IntFormat_Octal) + , char 'x' >> return (Conversion_Integer (IntFormat_Hex LowerCase)) + , char 'X' >> return (Conversion_Integer (IntFormat_Hex UpperCase)) + , char 'e' >> return (Conversion_Floating (FloatFormat_Scientific LowerCase)) + , char 'E' >> return (Conversion_Floating (FloatFormat_Scientific UpperCase)) + , char 'f' >> return (Conversion_Floating (FloatFormat_Standard LowerCase)) + , char 'F' >> return (Conversion_Floating (FloatFormat_Standard UpperCase)) + , char 'g' >> return (Conversion_Floating (FloatFormat_Auto LowerCase)) + , char 'G' >> return (Conversion_Floating (FloatFormat_Auto UpperCase)) + , char 'a' >> return (Conversion_Floating (FloatFormat_Hex LowerCase)) + , char 'A' >> return (Conversion_Floating (FloatFormat_Hex UpperCase)) + , char 'c' >> return Conversion_Char + , char 's' >> return Conversion_String + , char 'p' >> return Conversion_Pointer + , char 'n' >> return Conversion_CountChars + ] diff --git a/src/Lang/Crucible/LLVM/QQ.hs b/src/Lang/Crucible/LLVM/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/QQ.hs @@ -0,0 +1,384 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.QQ +-- Description : QuasiQuoters for a subset of LLVM assembly syntax +-- Copyright : (c) Galois, Inc 2019 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Lang.Crucible.LLVM.QQ + ( llvmType + , llvmDecl + , llvmOvr + ) where + +import Control.Monad (void) +import qualified Data.Attoparsec.Text as AT +import Data.Char +import Data.Data +import Data.Int +import qualified Data.Text as T +import qualified Text.LLVM.AST as L + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote + +import qualified Data.Parameterized.Context as Ctx +import Lang.Crucible.Types +import qualified Lang.Crucible.LLVM.Intrinsics.Common as IC +import Lang.Crucible.LLVM.Types + +-- | This type closely mirrors the type syntax from llvm-pretty, +-- but adds several additional constructors to represent +-- quasiquoter metavariables. +data QQType + = QQVar String -- ^ This constructor represents a type metavariable, e.g. @$var@ + | QQIntVar String -- ^ This constructor represents a integer type metavariable, e.g. @#var@ + | QQSizeT -- ^ This constructor represents an integer type that is the same width as a pointer + | QQSSizeT -- ^ This constructor represents a signed integer type that is the same width as a pointer + | QQPrim L.PrimType + | QQPtrTo QQType + | QQPtrOpaque + | QQAlias L.Ident + | QQArray Int32 QQType + | QQFunTy QQType [QQType] Bool + | QQStruct [QQType] + | QQPackedStruct [QQType] + | QQVector Int32 QQType + | QQOpaque + deriving (Show, Eq, Ord, Data) + +-- | This type closely mirrors the function declaration syntax from llvm-pretty, +-- except that the types and the name of the declaration may be metavarables. +data QQDeclare = + QQDeclare + { qqDecRet :: QQType + , qqDecName :: Either String L.Symbol -- ^ a @Left@ value is a metavariable; @Right@ is a symbol + , qqDecArgs :: [QQType] + , qqDecVarArgs :: Bool + } + deriving (Show, Eq, Ord, Data) + +parseIdent :: AT.Parser L.Ident +parseIdent = L.Ident <$> (AT.char '%' *> AT.choice + [ T.unpack <$> AT.takeWhile1 isDigit + , (:) <$> AT.satisfy (AT.inClass "-a-zA-Z$._") + <*> (T.unpack <$> (AT.takeWhile (AT.inClass "-a-zA-Z$._0-9"))) + ]) + + +parseSymbol :: AT.Parser L.Symbol +parseSymbol = L.Symbol <$> (AT.char '@' *> + ( (:) <$> AT.satisfy (AT.inClass "-a-zA-Z$._") + <*> (T.unpack <$> (AT.takeWhile (AT.inClass "-a-zA-Z$._0-9"))) + )) + +parseFloatType :: AT.Parser L.FloatType +parseFloatType = AT.choice + [ pure L.Half <* AT.string "half" + , pure L.Float <* AT.string "float" + , pure L.Double <* AT.string "double" + , pure L.Fp128 <* AT.string "fp128" + , pure L.X86_fp80 <* AT.string "x86_fp80" + , pure L.PPC_fp128 <* AT.string "ppc_fp128" + ] + +parsePrimType :: AT.Parser L.PrimType +parsePrimType = AT.choice + [ pure L.Label <* AT.string "label" + , pure L.Void <* AT.string "void" + , pure L.Metadata <* AT.string "metadata" + , pure L.X86mmx <* AT.string "x86_mmx" + , L.Integer <$> (AT.char 'i' *> AT.decimal) + , L.FloatType <$> parseFloatType + ] + +parseSeqType :: + Char -> + Char -> + (Int32 -> QQType -> QQType) -> + AT.Parser QQType +parseSeqType start end cnstr = + do void $ AT.char start + AT.skipSpace + n <- AT.decimal + AT.skipSpace + void $ AT.char 'x' + AT.skipSpace + tp <- parseType + AT.skipSpace + void $ AT.char end + return $! cnstr n tp + +parseCommaSeparatedTypes :: AT.Parser [QQType] +parseCommaSeparatedTypes = AT.choice + [ do AT.skipSpace + f <- parseType + fs <- AT.many' (AT.skipSpace *> AT.char ',' *> AT.skipSpace *> parseType) + return (f:fs) + , return [] + ] + +parseStructType :: AT.Parser QQType +parseStructType = + do void $ AT.char '{' + fs <- parseCommaSeparatedTypes + AT.skipSpace + void $ AT.char '}' + return $ QQStruct fs + +parsePackedStructType :: AT.Parser QQType +parsePackedStructType = + do void $ AT.string "<{" + fs <- parseCommaSeparatedTypes + AT.skipSpace + void $ AT.string "}>" + return $ QQPackedStruct fs + +parseArgList :: AT.Parser ([QQType], Bool) +parseArgList = + do void $ AT.char '(' + tps <- parseCommaSeparatedTypes + AT.skipSpace + varargs <- AT.choice + [ do void $ AT.char ',' + AT.skipSpace + void $ AT.string "..." + AT.skipSpace + void $ AT.char ')' + return True + , do void $ AT.char ')' + return False + ] + return (tps, varargs) + +parseVar :: AT.Parser String +parseVar = T.unpack <$> (AT.char '$' *> AT.takeWhile1 varChar) + where + varChar c = isAlpha c || isDigit c || c == '\'' || c == '_' + +parseIntVar :: AT.Parser String +parseIntVar = T.unpack <$> (AT.char '#' *> AT.takeWhile1 varChar) + where + varChar c = isAlpha c || isDigit c || c == '\'' || c == '_' + +parseType :: AT.Parser QQType +parseType = + do base <- AT.choice + [ parseSeqType '<' '>' QQVector + , parseSeqType '[' ']' QQArray + , parseStructType + , parsePackedStructType + , QQVar <$> parseVar + , QQIntVar <$> parseIntVar + , QQAlias <$> parseIdent + , QQPrim <$> parsePrimType + , pure QQOpaque <* AT.string "opaque" + , pure QQSizeT <* AT.string "size_t" + , pure QQSSizeT <* AT.string "ssize_t" + , pure QQPtrOpaque <* AT.string "ptr" + ] + base' <- AT.choice + [ do AT.skipSpace + (args,varargs) <- parseArgList + return (QQFunTy base args varargs) + , return base + ] + parseStars base' + + where + parseStars x = + AT.choice + [ do AT.skipSpace + void $ AT.char '*' + parseStars (QQPtrTo x) + , return x + ] + +parseDeclare :: AT.Parser QQDeclare +parseDeclare = + do AT.skipSpace + ret <- parseType + AT.skipSpace + sym <- AT.eitherP parseVar parseSymbol + AT.skipSpace + (args, varargs) <- parseArgList + AT.skipSpace + return + QQDeclare + { qqDecRet = ret + , qqDecName = sym + , qqDecArgs = args + , qqDecVarArgs = varargs + } + + +liftQQType :: QQType -> Q Exp +liftQQType tp = + case tp of + QQVar nm -> varE (mkName nm) + QQIntVar nm -> [| L.PrimType (L.Integer (fromInteger (intValue $(varE (mkName nm)) ))) |] + QQSizeT -> varE 'IC.llvmSizeT + QQSSizeT -> varE 'IC.llvmSSizeT + QQAlias nm -> [| L.Alias nm |] + QQPrim pt -> [| L.PrimType pt |] + QQPtrTo t -> [| L.PtrTo $(liftQQType t) |] + QQPtrOpaque -> [| L.PtrOpaque |] + QQArray n t -> [| L.Array n $(liftQQType t) |] + QQVector n t -> [| L.Vector n $(liftQQType t) |] + QQStruct ts -> [| L.Struct $(listE (map liftQQType ts)) |] + QQPackedStruct ts -> [| L.PackedStruct $(listE (map liftQQType ts)) |] + QQOpaque -> [| L.Opaque |] + QQFunTy ret args varargs -> [| L.FunTy $(liftQQType ret) $(listE (map liftQQType args)) $(lift varargs) |] + +liftQQDecl :: QQDeclare -> Q Exp +liftQQDecl (QQDeclare ret nm args varargs) = + [| L.Declare + { L.decLinkage = Nothing + , L.decVisibility = Nothing + , L.decRetType = $(liftQQType ret) + , L.decName = $(f nm) + , L.decArgs = $(listE (map liftQQType args)) + , L.decVarArgs = $(lift varargs) + , L.decAttrs = [] + , L.decComdat = Nothing + } + |] + where + f (Left v) = varE (mkName v) + f (Right sym) = lift sym + +liftKnownNat :: Integral a => a -> Q Exp +liftKnownNat n = [| knownNat @($(litT (numTyLit (toInteger n)))) |] + +liftTypeRepr :: QQType -> Q Exp +liftTypeRepr t = case t of + QQVar nm -> varE (mkName (nm++"_repr")) + QQIntVar nm -> [| BVRepr $(varE (mkName nm)) |] + QQSizeT -> [| SizeT |] + QQSSizeT -> [| SSizeT |] + QQPrim pt -> liftPrim pt + QQPtrTo _t -> [| PtrRepr |] + QQPtrOpaque -> [| PtrRepr |] + QQArray _ t' -> [| VectorRepr $(liftTypeRepr t') |] + QQVector _ t' -> [| VectorRepr $(liftTypeRepr t') |] + QQStruct ts -> [| StructRepr $(liftArgs ts False) |] + QQPackedStruct ts -> [| StructRepr $(liftArgs ts False) |] + QQAlias{} -> fail "Cannot lift alias type to repr" + QQOpaque -> fail "Cannot lift opaque type to repr" + QQFunTy{} -> fail "Cannot lift function type to repr" + where + liftPrim pt = case pt of + L.Void -> [| UnitRepr |] + L.Integer n -> [| BVRepr $(liftKnownNat n) |] + L.FloatType ft -> [| FloatRepr $(liftFloatType ft) |] + L.Label -> fail "Cannot lift label type to repr" + L.X86mmx -> fail "Cannot lift X86mmx type to repr" + L.Metadata -> fail "Cannot lift metatata type to repr" + + liftFloatType ft = case ft of + L.Half -> [| HalfFloatRepr |] + L.Float -> [| SingleFloatRepr |] + L.Double -> [| DoubleFloatRepr |] + L.Fp128 -> [| QuadFloatRepr |] + L.X86_fp80 -> [| X86_80FloatRepr |] + L.PPC_fp128 -> [| DoubleDoubleFloatRepr|] + +liftArgs :: [QQType] -> Bool -> Q Exp +liftArgs = go [| Ctx.Empty |] + where + go :: Q Exp -> [QQType] -> Bool -> Q Exp + go xs [] True = [| $(xs) Ctx.:> VectorRepr AnyRepr |] + go xs [] False = xs + go xs (t:ts) varargs = go [| $(xs) Ctx.:> $(liftTypeRepr t) |] ts varargs + + +liftQQDeclToOverride :: QQDeclare -> Q Exp +liftQQDeclToOverride qqd@(QQDeclare ret _nm args varargs) = + [| IC.LLVMOverride $(liftQQDecl qqd) $(liftArgs args varargs) $(liftTypeRepr ret) |] + +-- | This quasiquoter parses values in LLVM type syntax, extended +-- with metavariables, and builds values of @Text.LLVM.AST.Type@. +-- +-- Type metavariables start with a @$@ and splice in the named +-- program variable, which is expected to have type @Type@. +-- +-- Numeric metavariables start with @#@ and splice in an integer +-- type whose width is given by the named program variable, which +-- is expected to be a @NatRepr@. +llvmType :: QuasiQuoter +llvmType = + QuasiQuoter + { quoteExp = \str -> + do case AT.parseOnly parseType (T.pack str) of + Left msg -> error msg + Right x -> liftQQType x + + , quotePat = error "llvmType cannot quasiquote a pattern" + , quoteType = error "llvmType cannot quasiquote a Haskell type" + , quoteDec = error "llvmType cannot quasiquote a declaration" + } + +-- | This quasiquoter parses values in LLVM function declaration syntax, +-- extended with metavariables, and builds values of @Text.LLVM.AST.Declare@. +-- +-- Type metavariables start with a @$@ and splice in the named +-- program variable, which is expected to have type @Type@. +-- +-- Numeric metavariables start with @#@ and splice in an integer +-- type whose width is given by the named program variable, which +-- is expected to be a @NatRepr@. +-- +-- The name of the declaration may also be a @$@ metavariable, in which +-- case the named variable is expeted to be a @Symbol@. +llvmDecl :: QuasiQuoter +llvmDecl = + QuasiQuoter + { quoteExp = \str -> + do case AT.parseOnly parseDeclare (T.pack str) of + Left msg -> error msg + Right x -> liftQQDecl x + + , quotePat = error "llvmDecl cannot quasiquote a pattern" + , quoteType = error "llvmDecl cannot quasiquote a Haskell type" + , quoteDec = error "llvmDecl cannot quasiquote a declaration" + } + +-- | This quasiquoter parses values in LLVM function declaration syntax, +-- extended with metavariables, and partially applies the +-- @LLVMOverride@ constructor so that it expectes a single remaining +-- argument to populate the @llvmOverride_def@ field. +-- +-- Type metavariables start with a @$@ and splice in the named +-- program variable, which is expected to have type @Type@. +-- In addition a related variable must be in scope to give the +-- crucible @TypeRepr@ associated. For example variable @$x@ +-- should be a LLVM @Type@ and @$x_repr@ should be a Crucible @TypeRepr@. +-- +-- Numeric metavariables start with @#@ and splice in an integer +-- type whose width is given by the named program variable, which +-- is expected to be a @NatRepr@. Both the LLVM type and the Crucible +-- @TypeRepr@ are built from the @NatRepr@. +-- +-- The name of the declaration may also be a @$@ metavariable, in which +-- case the named variable is expeted to be a @Symbol@. +llvmOvr :: QuasiQuoter +llvmOvr = + QuasiQuoter + { quoteExp = \str -> + do case AT.parseOnly parseDeclare (T.pack str) of + Left msg -> error msg + Right x -> liftQQDeclToOverride x + + , quotePat = error "llvmOvr cannot quasiquote a pattern" + , quoteType = error "llvmOvr cannot quasiquote a Haskell type" + , quoteDec = error "llvmOvr cannot quasiquote a declaration" + } diff --git a/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs b/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/SimpleLoopFixpoint.hs @@ -0,0 +1,892 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.SimpleLoopFixpoint +-- Description : Execution feature to compute loop fixpoint +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Stability : provisional +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Lang.Crucible.LLVM.SimpleLoopFixpoint + ( FixpointEntry(..) + , simpleLoopFixpoint + ) where + +import Control.Lens +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State (MonadState(..), StateT(..)) +import Control.Monad.Trans.Maybe +import Data.Either +import Data.Foldable +import qualified Data.IntMap as IntMap +import Data.IORef +import qualified Data.List as List +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified System.IO +import Numeric.Natural + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Map (MapF) +import Data.Parameterized.NatRepr +import Data.Parameterized.TraversableF +import Data.Parameterized.TraversableFC + +import qualified What4.Config as W4 +import qualified What4.Interface as W4 + +import qualified Lang.Crucible.Analysis.Fixpoint.Components as C +import qualified Lang.Crucible.Backend as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.Panic as C +import qualified Lang.Crucible.Simulator.CallFrame as C +import qualified Lang.Crucible.Simulator.EvalStmt as C +import qualified Lang.Crucible.Simulator.ExecutionTree as C +import qualified Lang.Crucible.Simulator.GlobalState as C +import qualified Lang.Crucible.Simulator.Operations as C +import qualified Lang.Crucible.Simulator.RegMap as C +import qualified Lang.Crucible.Simulator as C + +import qualified Lang.Crucible.LLVM.Bytes as C +import qualified Lang.Crucible.LLVM.DataLayout as C +import qualified Lang.Crucible.LLVM.MemModel as C +import qualified Lang.Crucible.LLVM.MemModel.MemLog as C hiding (Mem) +import qualified Lang.Crucible.LLVM.MemModel.Pointer as C +import qualified Lang.Crucible.LLVM.MemModel.Type as C + + +-- | When live loop-carried dependencies are discovered as we traverse +-- a loop body, new "widening" variables are introduced to stand in +-- for those locations. When we introduce such a varible, we +-- capture what value the variable had when we entered the loop (the +-- \"header\" value); this is essentially the initial value of the +-- variable. We also compute what value the variable should take on +-- its next iteration assuming the loop doesn't exit and executes +-- along its backedge. This \"body\" value will be computed in +-- terms of the the set of all discovered live variables so far. +-- We know we have reached fixpoint when we don't need to introduce +-- and more fresh widening variables, and the body values for each +-- variable are stable across iterations. +data FixpointEntry sym tp = FixpointEntry + { headerValue :: W4.SymExpr sym tp + , bodyValue :: W4.SymExpr sym tp + } + +instance OrdF (W4.SymExpr sym) => OrdF (FixpointEntry sym) where + compareF x y = case compareF (headerValue x) (headerValue y) of + LTF -> LTF + EQF -> compareF (bodyValue x) (bodyValue y) + GTF -> GTF + +instance OrdF (FixpointEntry sym) => W4.TestEquality (FixpointEntry sym) where + testEquality x y = case compareF x y of + EQF -> Just Refl + _ -> Nothing + +data MemFixpointEntry sym = forall w . (1 <= w) => MemFixpointEntry + { memFixpointEntrySym :: sym + , memFixpointEntryJoinVariable :: W4.SymBV sym w + } + +-- | This datatype captures the state machine that progresses as we +-- attempt to compute a loop invariant for a simple structured loop. +data FixpointState sym blocks + -- | We have not yet encoundered the loop head + = BeforeFixpoint + + -- | We have encountered the loop head at least once, and are in the process + -- of converging to an inductive representation of the live variables + -- in the loop. + | ComputeFixpoint (FixpointRecord sym blocks) + + -- | We have found an inductively-strong representation of the live variables + -- of the loop, and have discovered the loop index structure controling the + -- execution of the loop. We are now executing the loop once more to compute + -- verification conditions for executions that reamain in the loop. + | CheckFixpoint + (FixpointRecord sym blocks) + (LoopIndexBound sym) -- ^ data about the fixed sort of loop index values we are trying to find + + -- | Finally, we stitch everything we have found together into the rest of the program. + -- Starting from the loop header one final time, we now force execution to exit the loop + -- and continue into the rest of the program. + | AfterFixpoint + (FixpointRecord sym blocks) + (LoopIndexBound sym) -- ^ data about the fixed sort of loop index values we are trying to find + +-- | Data about the loop that we incrementally compute as we approach fixpoint. +data FixpointRecord sym blocks = forall args. + FixpointRecord + { + -- | Block identifier of the head of the loop + fixpointBlockId :: C.Some (C.BlockID blocks) + + -- | identifier for the currently-active assumption frame related to this fixpoint computation + , fixpointAssumptionFrameIdentifier :: C.FrameIdentifier + + -- | Map from introduced widening variables to prestate value before the loop starts, + -- and to the value computed in a single loop iteration, assuming we return to the + -- loop header. These variables may appear only in either registers or memory. + , fixpointSubstitution :: MapF (W4.SymExpr sym) (FixpointEntry sym) + + -- | Prestate values of the Crucible registers when the loop header is first encountered. + , fixpointRegMap :: C.RegMap sym args + + -- | Triples are (blockId, offset, size) to bitvector-typed entries ( bitvector only/not pointers ) + , fixpointMemSubstitution :: Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType) + + -- | Condition which, when true, stays in the loop. This is captured when the (unique, by assumption) + -- symbolic branch that exits the loop is encountered. This condition is updated on each iteration + -- as we widen the invariant. + , fixpointLoopCondition :: Maybe (W4.Pred sym) + } + + +fixpointRecord :: FixpointState sym blocks -> Maybe (FixpointRecord sym blocks) +fixpointRecord BeforeFixpoint = Nothing +fixpointRecord (ComputeFixpoint r) = Just r +fixpointRecord (CheckFixpoint r _) = Just r +fixpointRecord (AfterFixpoint r _) = Just r + + +type FixpointMonad sym = StateT (MapF (W4.SymExpr sym) (FixpointEntry sym)) IO + + +joinRegEntries :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + sym -> + Ctx.Assignment (C.RegEntry sym) ctx -> + Ctx.Assignment (C.RegEntry sym) ctx -> + FixpointMonad sym (Ctx.Assignment (C.RegEntry sym) ctx) +joinRegEntries sym = Ctx.zipWithM (joinRegEntry sym) + +joinRegEntry :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + sym -> + C.RegEntry sym tp -> + C.RegEntry sym tp -> + FixpointMonad sym (C.RegEntry sym tp) +joinRegEntry sym left right = case C.regType left of + C.LLVMPointerRepr w + + -- special handling for "don't care" registers coming from Macaw + | List.isPrefixOf "cmacaw_reg" (show $ W4.printSymNat $ C.llvmPointerBlock (C.regValue left)) + , List.isPrefixOf "cmacaw_reg" (show $ W4.printSymExpr $ C.llvmPointerOffset (C.regValue left)) -> do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: cmacaw_reg" + return left + + | C.llvmPointerBlock (C.regValue left) == C.llvmPointerBlock (C.regValue right) -> do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr" + subst <- get + if isJust (W4.testEquality (C.llvmPointerOffset (C.regValue left)) (C.llvmPointerOffset (C.regValue right))) + then do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: left == right" + return left + else case MapF.lookup (C.llvmPointerOffset (C.regValue left)) subst of + Just join_entry -> do + liftIO $ ?logMessage $ + "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Just: " + ++ show (W4.printSymExpr $ bodyValue join_entry) + ++ " -> " + ++ show (W4.printSymExpr $ C.llvmPointerOffset (C.regValue right)) + put $ MapF.insert + (C.llvmPointerOffset (C.regValue left)) + (join_entry { bodyValue = C.llvmPointerOffset (C.regValue right) }) + subst + return left + Nothing -> do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: Nothing" + join_varaible <- liftIO $ W4.freshConstant sym (userSymbol' "reg_join_var") (W4.BaseBVRepr w) + let join_entry = FixpointEntry + { headerValue = C.llvmPointerOffset (C.regValue left) + , bodyValue = C.llvmPointerOffset (C.regValue right) + } + put $ MapF.insert join_varaible join_entry subst + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) join_varaible + | otherwise -> + fail $ + "SimpleLoopFixpoint.joinRegEntry: LLVMPointerRepr: unsupported pointer base join: " + ++ show (C.ppPtr $ C.regValue left) + ++ " \\/ " + ++ show (C.ppPtr $ C.regValue right) + + C.BoolRepr + | List.isPrefixOf "cmacaw" (show $ W4.printSymExpr $ C.regValue left) -> do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: cmacaw_reg" + return left + | otherwise -> do + liftIO $ ?logMessage $ + "SimpleLoopFixpoint.joinRegEntry: BoolRepr:" + ++ show (W4.printSymExpr $ C.regValue left) + ++ " \\/ " + ++ show (W4.printSymExpr $ C.regValue right) + join_varaible <- liftIO $ W4.freshConstant sym (userSymbol' "macaw_reg") W4.BaseBoolRepr + return $ C.RegEntry C.BoolRepr join_varaible + + C.StructRepr field_types -> do + liftIO $ ?logMessage "SimpleLoopFixpoint.joinRegEntry: StructRepr" + C.RegEntry (C.regType left) <$> fmapFC (C.RV . C.regValue) <$> joinRegEntries sym + (Ctx.generate (Ctx.size field_types) $ \i -> + C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue left) Ctx.! i) + (Ctx.generate (Ctx.size field_types) $ \i -> + C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue right) Ctx.! i) + _ -> fail $ "SimpleLoopFixpoint.joinRegEntry: unsupported type: " ++ show (C.regType left) + + +applySubstitutionRegEntries :: + C.IsSymInterface sym => + sym -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + Ctx.Assignment (C.RegEntry sym) ctx -> + Ctx.Assignment (C.RegEntry sym) ctx +applySubstitutionRegEntries sym substitution = fmapFC (applySubstitutionRegEntry sym substitution) + +applySubstitutionRegEntry :: + C.IsSymInterface sym => + sym -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + C.RegEntry sym tp -> + C.RegEntry sym tp +applySubstitutionRegEntry sym substitution entry = case C.regType entry of + C.LLVMPointerRepr{} -> + entry + { C.regValue = C.LLVMPointer + (C.llvmPointerBlock (C.regValue entry)) + (MapF.findWithDefault + (C.llvmPointerOffset (C.regValue entry)) + (C.llvmPointerOffset (C.regValue entry)) + substitution) + } + C.BoolRepr -> + entry + C.StructRepr field_types -> + entry + { C.regValue = fmapFC (C.RV . C.regValue) $ + applySubstitutionRegEntries sym substitution $ + Ctx.generate (Ctx.size field_types) $ + \i -> C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue entry) Ctx.! i + } + _ -> C.panic "SimpleLoopFixpoint.applySubstitutionRegEntry" ["unsupported type: " ++ show (C.regType entry)] + + +findLoopIndex :: + (?logMessage :: String -> IO (), C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + IO (W4.SymBV sym wptr, Natural, Natural) +findLoopIndex sym substitution = do + candidates <- catMaybes <$> mapM + (\(MapF.Pair variable FixpointEntry{..}) -> case W4.testEquality (W4.BaseBVRepr ?ptrWidth) (W4.exprType variable) of + Just Refl -> do + diff <- liftIO $ W4.bvSub sym bodyValue variable + case (BV.asNatural <$> W4.asBV headerValue, BV.asNatural <$> W4.asBV diff) of + (Just start, Just step) -> do + liftIO $ ?logMessage $ + "SimpleLoopFixpoint.findLoopIndex: " ++ show (W4.printSymExpr variable) ++ "=" ++ show (start, step) + return $ Just (variable, start, step) + _ -> return Nothing + Nothing -> return Nothing) + (MapF.toList substitution) + case candidates of + [candidate] -> return candidate + _ -> fail "SimpleLoopFixpoint.findLoopIndex: loop index identification failure." + +findLoopBound :: + (C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + W4.Pred sym -> + Natural -> + Natural -> + IO (W4.SymBV sym wptr) +findLoopBound sym condition _start step = + case Set.toList $ W4.exprUninterpConstants sym condition of + + -- this is a grungy hack, we are expecting exactly three variables and take the first + [C.Some loop_stop, _, _] + | Just Refl <- W4.testEquality (W4.BaseBVRepr ?ptrWidth) (W4.exprType $ W4.varExpr sym loop_stop) -> + W4.bvMul sym (W4.varExpr sym loop_stop) =<< W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral step) + _ -> fail "SimpleLoopFixpoint.findLoopBound: loop bound identification failure." + + +-- index variable information for fixed stride, bounded loops +data LoopIndexBound sym = forall w . 1 <= w => LoopIndexBound + { index :: W4.SymBV sym w + , start :: Natural + , stop :: W4.SymBV sym w + , step :: Natural + } + +findLoopIndexBound :: + (?logMessage :: String -> IO (), C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + Maybe (W4.Pred sym) -> + IO (LoopIndexBound sym) +findLoopIndexBound _sym _substitition Nothing = + fail "findLoopIndexBound: no loop condition recorded!" + +findLoopIndexBound sym substitution (Just condition) = do + (loop_index, start, step) <- findLoopIndex sym substitution + stop <- findLoopBound sym condition start step + return $ LoopIndexBound + { index = loop_index + , start = start + , stop = stop + , step = step + } + +-- hard-coded here that we are always looking for a loop condition delimited by an unsigned comparison +loopIndexBoundCondition :: + (C.IsSymInterface sym, 1 <= w) => + sym -> + W4.SymBV sym w -> + W4.SymBV sym w -> + IO (W4.Pred sym) +loopIndexBoundCondition = W4.bvUlt + +-- | Describes an assumed invariant on the loop index variable, which is that it is an offset +-- from the initial value that is a multiple of a discoveded stride value. +loopIndexStartStepCondition :: + C.IsSymInterface sym => + sym -> + LoopIndexBound sym -> + IO (W4.Pred sym) +loopIndexStartStepCondition sym LoopIndexBound{ index = loop_index, start = start, step = step } = do + start_bv <- W4.bvLit sym (W4.bvWidth loop_index) (BV.mkBV (W4.bvWidth loop_index) $ fromIntegral start) + step_bv <- W4.bvLit sym (W4.bvWidth loop_index) (BV.mkBV (W4.bvWidth loop_index) $ fromIntegral step) + W4.bvEq sym start_bv =<< W4.bvUrem sym loop_index step_bv + + +loadMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType) -> + IO (MapF (W4.SymExpr sym) (W4.SymExpr sym)) +loadMemJoinVariables bak mem subst = + let sym = C.backendGetSym bak in + MapF.fromList <$> mapM + (\((blk, off, _sz), (MemFixpointEntry { memFixpointEntryJoinVariable = join_varaible }, storeage_type)) -> do + ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral off) + val <- C.doLoad bak mem ptr storeage_type (C.LLVMPointerRepr $ W4.bvWidth join_varaible) C.noAlignment + case W4.asNat (C.llvmPointerBlock val) of + Just 0 -> return $ MapF.Pair join_varaible $ C.llvmPointerOffset val + _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" ++ show (C.ppPtr val)) + (Map.toAscList subst) + +storeMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + Map (Natural, Natural, Natural) (MemFixpointEntry sym, C.StorageType) -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + IO (C.MemImpl sym) +storeMemJoinVariables bak mem mem_subst eq_subst = + let sym = C.backendGetSym bak in + foldlM + (\mem_acc ((blk, off, _sz), (MemFixpointEntry { memFixpointEntryJoinVariable = join_varaible }, storeage_type)) -> do + ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth $ fromIntegral off) + C.doStore bak mem_acc ptr (C.LLVMPointerRepr $ W4.bvWidth join_varaible) storeage_type C.noAlignment =<< + C.llvmPointer_bv sym (MapF.findWithDefault join_varaible join_varaible eq_subst)) + mem + (Map.toAscList mem_subst) + +dropMemStackFrame :: C.IsSymInterface sym => C.MemImpl sym -> (C.MemImpl sym, C.MemAllocs sym, C.MemWrites sym) +dropMemStackFrame mem = case (C.memImplHeap mem) ^. C.memState of + (C.StackFrame _ _ _ (a, w) s) -> ((mem { C.memImplHeap = (C.memImplHeap mem) & C.memState .~ s }), a, w) + _ -> C.panic "SimpleLoopFixpoint.dropMemStackFrame" ["not a stack frame:", show (C.ppMem $ C.memImplHeap mem)] + + +filterSubstitution :: + C.IsSymInterface sym => + sym -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + MapF (W4.SymExpr sym) (FixpointEntry sym) +filterSubstitution sym substitution = + -- TODO: fixpoint + let uninterp_constants = foldMapF + (Set.map (C.mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . bodyValue) + substitution + in + MapF.filterWithKey (\variable _entry -> Set.member (C.Some variable) uninterp_constants) substitution + +-- find widening variables that are actually the same (up to syntactic equality) +-- and can be substituted for each other +uninterpretedConstantEqualitySubstitution :: + forall sym . + C.IsSymInterface sym => + sym -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + (MapF (W4.SymExpr sym) (FixpointEntry sym), MapF (W4.SymExpr sym) (W4.SymExpr sym)) +uninterpretedConstantEqualitySubstitution _sym substitution = + let reverse_substitution = MapF.foldlWithKey' + (\accumulator variable entry -> MapF.insert entry variable accumulator) + MapF.empty + substitution + uninterpreted_constant_substitution = fmapF + (\entry -> fromJust $ MapF.lookup entry reverse_substitution) + substitution + normal_substitution = MapF.filterWithKey + (\variable _entry -> + Just Refl == W4.testEquality variable (fromJust $ MapF.lookup variable uninterpreted_constant_substitution)) + substitution + in + (normal_substitution, uninterpreted_constant_substitution) + + +userSymbol' :: String -> W4.SolverSymbol +userSymbol' = fromRight (C.panic "SimpleLoopFixpoint.userSymbol'" []) . W4.userSymbol + + +-- | This execution feature is designed to allow a limited form of +-- verification for programs with unbounded looping structures. +-- +-- It is currently highly experimental and has many limititations. +-- Most notibly, it only really works properly for functions +-- consiting of a single, non-nested loop with a single exit point. +-- Moreover, the loop must have an indexing variable that counts up +-- from a starting point by a fixed stride amount. +-- +-- Currently, these assumptions about the loop strucutre are not +-- checked. +-- +-- The basic use case here is for verifiying functions that loop +-- through an array of data of symbolic length. This is done by +-- providing a \""fixpoint function\" which describes how the live +-- values in the loop at an arbitrary iteration are used to compute +-- the final values of those variables before execution leaves the +-- loop. The number and order of these variables depends on +-- internal details of the representation, so is relatively fragile. +simpleLoopFixpoint :: + forall sym ext p rtp blocks init ret . + (C.IsSymInterface sym, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + sym -> + C.CFG ext blocks init ret {- ^ The function we want to verify -} -> + C.GlobalVar C.Mem {- ^ global variable representing memory -} -> + (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), W4.Pred sym)) -> + IO (C.ExecutionFeature p sym ext rtp) +simpleLoopFixpoint sym cfg@C.CFG{..} mem_var fixpoint_func = do + let ?ptrWidth = knownNat @64 + + verbSetting <- W4.getOptionSetting W4.verbosity $ W4.getConfiguration sym + verb <- fromInteger <$> W4.getOpt verbSetting + + -- Doesn't really work if there are nested loops: looop datastructures will + -- overwrite each other. Currently no error message. + + -- Really only works for single-exit loops; need a message for that too. + + let flattenWTOComponent = \case + C.SCC C.SCCData{..} -> wtoHead : concatMap flattenWTOComponent wtoComps + C.Vertex v -> [v] + let loop_map = Map.fromList $ mapMaybe + (\case + C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps) + C.Vertex{} -> Nothing) + (C.cfgWeakTopologicalOrdering cfg) + + fixpoint_state_ref <- newIORef @(FixpointState sym blocks) BeforeFixpoint + + return $ C.ExecutionFeature $ \exec_state -> do + let ?logMessage = \msg -> when (verb >= (3 :: Natural)) $ do + let h = C.printHandle $ C.execStateContext exec_state + System.IO.hPutStrLn h msg + System.IO.hFlush h + fixpoint_state <- readIORef fixpoint_state_ref + C.withBackend (C.execStateContext exec_state) $ \bak -> + case exec_state of + C.RunningState (C.RunBlockStart block_id) sim_state + | C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + + -- make sure the types match + , Just Refl <- W4.testEquality + (fmapFC C.blockInputs cfgBlockMap) + (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + + -- loop map is what we computed above, is this state at a loop header + , Map.member (C.Some block_id) loop_map -> + + advanceFixpointState bak mem_var fixpoint_func block_id sim_state fixpoint_state fixpoint_state_ref + + | otherwise -> do + ?logMessage $ "SimpleLoopFixpoint: RunningState: RunBlockStart: " ++ show block_id + return C.ExecutionFeatureNoChange + + + -- TODO: maybe need to rework this, so that we are sure to capture even concrete exits from the loop. + C.SymbolicBranchState branch_condition true_frame false_frame _target sim_state + | Just fixpoint_record <- fixpointRecord fixpoint_state + , Just loop_body_some_block_ids <- Map.lookup (fixpointBlockId fixpoint_record) loop_map + , JustPausedFrameTgtId true_frame_some_block_id <- pausedFrameTgtId true_frame + , JustPausedFrameTgtId false_frame_some_block_id <- pausedFrameTgtId false_frame + , C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + , Just Refl <- W4.testEquality + (fmapFC C.blockInputs cfgBlockMap) + (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + , elem true_frame_some_block_id loop_body_some_block_ids /= elem false_frame_some_block_id loop_body_some_block_ids -> do + + (loop_condition, inside_loop_frame, outside_loop_frame) <- + if elem true_frame_some_block_id loop_body_some_block_ids + then + return (branch_condition, true_frame, false_frame) + else do + not_branch_condition <- W4.notPred sym branch_condition + return (not_branch_condition, false_frame, true_frame) + + (condition, frame) <- case fixpoint_state of + BeforeFixpoint -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint:" ["BeforeFixpoint"] + + ComputeFixpoint _fixpoint_record -> do + -- continue in the loop + ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: ComputeFixpoint" + writeIORef fixpoint_state_ref $ + ComputeFixpoint fixpoint_record { fixpointLoopCondition = Just loop_condition } + return (loop_condition, inside_loop_frame) + + CheckFixpoint _fixpoint_record _loop_bound -> do + -- continue in the loop + ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: CheckFixpoint" + return (loop_condition, inside_loop_frame) + + AfterFixpoint _fixpoint_record _loop_bound -> do + -- break out of the loop + ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: AfterFixpoint" + not_loop_condition <- W4.notPred sym loop_condition + return (not_loop_condition, outside_loop_frame) + + loc <- W4.getCurrentProgramLoc sym + C.addAssumption bak $ C.BranchCondition loc (C.pausedLoc frame) condition + C.ExecutionFeatureNewState <$> + runReaderT + (C.resumeFrame (C.forgetPostdomFrame frame) $ sim_state ^. (C.stateTree . C.actContext)) + sim_state + + _ -> return C.ExecutionFeatureNoChange + + +advanceFixpointState :: + forall sym bak ext p rtp blocks r args . + (C.IsSymBackend sym bak, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) => + bak -> + C.GlobalVar C.Mem -> + (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), W4.Pred sym)) -> + C.BlockID blocks args -> + C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) -> + FixpointState sym blocks -> + IORef (FixpointState sym blocks) -> + IO (C.ExecutionFeatureResult p sym ext rtp) + +advanceFixpointState bak mem_var fixpoint_func block_id sim_state fixpoint_state fixpoint_state_ref = + let ?ptrWidth = knownNat @64 in + let sym = C.backendGetSym bak in + case fixpoint_state of + BeforeFixpoint -> do + ?logMessage $ "SimpleLoopFixpoint: RunningState: BeforeFixpoint -> ComputeFixpoint" + assumption_frame_identifier <- C.pushAssumptionFrame bak + let mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) + let res_mem_impl = mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" $ C.memImplHeap mem_impl } + writeIORef fixpoint_state_ref $ ComputeFixpoint $ + FixpointRecord + { fixpointBlockId = C.Some block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = MapF.empty + , fixpointRegMap = sim_state ^. (C.stateCrucibleFrame . C.frameRegs) + , fixpointMemSubstitution = Map.empty + , fixpointLoopCondition = Nothing -- we don't know the loop condition yet + } + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + ComputeFixpoint fixpoint_record + | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record + , Just Refl <- W4.testEquality + (fmapFC C.regType $ C.regMap reg_map) + (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do + + + ?logMessage $ "SimpleLoopFixpoint: RunningState: ComputeFixpoint: " ++ show block_id + _ <- C.popAssumptionFrameAndObligations bak $ fixpointAssumptionFrameIdentifier fixpoint_record + + -- widen the inductive condition + (join_reg_map, join_substitution) <- runStateT + (joinRegEntries sym + (C.regMap reg_map) + (C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs))) $ + fixpointSubstitution fixpoint_record + + let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) + let (header_mem_impl, mem_allocs, mem_writes) = dropMemStackFrame body_mem_impl + when (C.sizeMemAllocs mem_allocs /= 0) $ + fail "SimpleLoopFixpoint: unsupported memory allocation in loop body." + + -- widen the memory + mem_substitution_candidate <- Map.fromList <$> catMaybes <$> case mem_writes of + C.MemWrites [C.MemWritesChunkIndexed mmm] -> mapM + (\case + (C.MemWrite ptr (C.MemStore _ storeage_type _)) + | Just blk <- W4.asNat (C.llvmPointerBlock ptr) + , Just off <- BV.asNatural <$> W4.asBV (C.llvmPointerOffset ptr) -> do + let sz = C.typeEnd 0 storeage_type + some_join_varaible <- liftIO $ case W4.mkNatRepr $ C.bytesToBits sz of + C.Some bv_width + | Just C.LeqProof <- W4.testLeq (W4.knownNat @1) bv_width -> do + join_varaible <- W4.freshConstant sym + (userSymbol' "mem_join_var") + (W4.BaseBVRepr bv_width) + return $ MemFixpointEntry + { memFixpointEntrySym = sym + , memFixpointEntryJoinVariable = join_varaible + } + | otherwise -> + C.panic + "SimpleLoopFixpoint.simpleLoopFixpoint" + ["unexpected storage type " ++ show storeage_type ++ " of size " ++ show sz] + return $ Just ((blk, off, fromIntegral sz), (some_join_varaible, storeage_type)) + | Just blk <- W4.asNat (C.llvmPointerBlock ptr) + , Just Refl <- W4.testEquality ?ptrWidth (C.ptrWidth ptr) -> do + maybe_ranges <- runMaybeT $ + C.writeRangesMem @_ @64 sym $ C.memImplHeap header_mem_impl + case maybe_ranges of + Just ranges -> do + sz <- W4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth $ toInteger $ C.typeEnd 0 storeage_type + forM_ (Map.findWithDefault [] blk ranges) $ \(prev_off, prev_sz) -> do + disjoint_pred <- C.buildDisjointRegionsAssertionWithSub + sym + ptr + sz + (C.LLVMPointer (C.llvmPointerBlock ptr) prev_off) + prev_sz + when (W4.asConstantPred disjoint_pred /= Just True) $ + fail $ + "SimpleLoopFixpoint: non-disjoint ranges: off1=" + ++ show (W4.printSymExpr (C.llvmPointerOffset ptr)) + ++ ", sz1=" + ++ show (W4.printSymExpr sz) + ++ ", off2=" + ++ show (W4.printSymExpr prev_off) + ++ ", sz2=" + ++ show (W4.printSymExpr prev_sz) + return Nothing + Nothing -> fail $ "SimpleLoopFixpoint: unsupported symbolic pointers" + _ -> fail $ "SimpleLoopFixpoint: not MemWrite: " ++ show (C.ppMemWrites mem_writes)) + (List.concat $ IntMap.elems mmm) + _ -> fail $ "SimpleLoopFixpoint: not MemWritesChunkIndexed: " ++ show (C.ppMemWrites mem_writes) + + -- check that the mem substitution always computes the same footprint on every iteration (!?!) + mem_substitution <- if Map.null (fixpointMemSubstitution fixpoint_record) + then return mem_substitution_candidate + else if Map.keys mem_substitution_candidate == Map.keys (fixpointMemSubstitution fixpoint_record) + then return $ fixpointMemSubstitution fixpoint_record + else fail "SimpleLoopFixpoint: unsupported memory writes change" + + assumption_frame_identifier <- C.pushAssumptionFrame bak + + -- check if we are done; if we did not introduce any new variables, we don't have to widen any more + if MapF.keys join_substitution == MapF.keys (fixpointSubstitution fixpoint_record) + + -- we found the fixpoint, get ready to wrap up + then do + ?logMessage $ + "SimpleLoopFixpoint: RunningState: ComputeFixpoint -> CheckFixpoint" + ?logMessage $ + "SimpleLoopFixpoint: cond: " ++ + show (maybe "Nothing" W4.printSymExpr $ fixpointLoopCondition fixpoint_record) + + -- we have delayed populating the main substituation map with + -- memory variables, so we have to do that now + + header_mem_substitution <- loadMemJoinVariables bak header_mem_impl $ + fixpointMemSubstitution fixpoint_record + body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ + fixpointMemSubstitution fixpoint_record + + -- try to unify widening variables that have the same values + let (normal_substitution, equality_substitution) = uninterpretedConstantEqualitySubstitution sym $ + -- drop variables that don't appear along some back edge (? understand this better) + filterSubstitution sym $ + MapF.union join_substitution $ + -- this implements zip, because the two maps have the same keys + MapF.intersectWithKeyMaybe + (\_k x y -> Just $ FixpointEntry{ headerValue = x, bodyValue = y }) + header_mem_substitution + body_mem_substitution + -- ?logMessage $ "normal_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList normal_substitution) + -- ?logMessage $ "equality_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList equality_substitution) + + -- unify widening variables in the register subst + let res_reg_map = applySubstitutionRegEntries sym equality_substitution join_reg_map + + -- unify widening varialbes in the memory subst + res_mem_impl <- storeMemJoinVariables + bak + (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) }) + mem_substitution + equality_substitution + + -- finally we can determine the loop bounds + loop_index_bound <- findLoopIndexBound sym normal_substitution $ fixpointLoopCondition fixpoint_record + + (_ :: ()) <- case loop_index_bound of + LoopIndexBound{ index = loop_index, stop = loop_stop } -> do + loc <- W4.getCurrentProgramLoc sym + index_bound_condition <- loopIndexBoundCondition sym loop_index loop_stop + C.addAssumption bak $ C.GenericAssumption loc "" index_bound_condition + index_start_step_condition <- loopIndexStartStepCondition sym loop_index_bound + C.addAssumption bak $ C.GenericAssumption loc "" index_start_step_condition + + writeIORef fixpoint_state_ref $ + CheckFixpoint + FixpointRecord + { fixpointBlockId = C.Some block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = normal_substitution + , fixpointRegMap = C.RegMap res_reg_map + , fixpointMemSubstitution = mem_substitution + , fixpointLoopCondition = fixpointLoopCondition fixpoint_record + } + loop_index_bound + + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap res_reg_map + & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + else do + ?logMessage $ + "SimpleLoopFixpoint: RunningState: ComputeFixpoint: -> ComputeFixpoint" + + -- write any new widening variables into memory state + res_mem_impl <- storeMemJoinVariables bak + (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) }) + mem_substitution + MapF.empty + + writeIORef fixpoint_state_ref $ ComputeFixpoint + FixpointRecord + { fixpointBlockId = C.Some block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = join_substitution + , fixpointRegMap = C.RegMap join_reg_map + , fixpointMemSubstitution = mem_substitution + , fixpointLoopCondition = Nothing + } + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap join_reg_map + & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: ComputeFixpoint"] + + CheckFixpoint fixpoint_record loop_bound + | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record + , Just Refl <- W4.testEquality + (fmapFC C.regType $ C.regMap reg_map) + (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do + ?logMessage $ + "SimpleLoopFixpoint: RunningState: " + ++ "CheckFixpoint" + ++ " -> " + ++ "AfterFixpoint" + ++ ": " + ++ show block_id + + loc <- W4.getCurrentProgramLoc sym + + -- assert that the hypothesis we made about the loop termination condition is true + (_ :: ()) <- case loop_bound of + LoopIndexBound{ index = loop_index, stop = loop_stop } -> do + -- check the loop index bound condition + index_bound_condition <- loopIndexBoundCondition + sym + (bodyValue $ fromJust $ MapF.lookup loop_index $ fixpointSubstitution fixpoint_record) + loop_stop + C.addProofObligation bak $ C.LabeledPred index_bound_condition $ C.SimError loc "" + + _ <- C.popAssumptionFrame bak $ fixpointAssumptionFrameIdentifier fixpoint_record + + let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) + let (header_mem_impl, _mem_allocs, _mem_writes) = dropMemStackFrame body_mem_impl + + body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ fixpointMemSubstitution fixpoint_record + let res_substitution = MapF.mapWithKey + (\variable fixpoint_entry -> + fixpoint_entry + { bodyValue = MapF.findWithDefault (bodyValue fixpoint_entry) variable body_mem_substitution + }) + (fixpointSubstitution fixpoint_record) + -- ?logMessage $ "res_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList res_substitution) + + -- match things up with the input function that describes the loop body behavior + (fixpoint_func_substitution, fixpoint_func_condition) <- liftIO $ + case fixpointLoopCondition fixpoint_record of + Nothing -> fail "When checking the result of a fixpoint, no loop condition was found!" + Just c -> fixpoint_func res_substitution c + + C.addProofObligation bak $ C.LabeledPred fixpoint_func_condition $ C.SimError loc "" + -- ?logMessage $ "fixpoint_func_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList fixpoint_func_substitution) + + let res_reg_map = C.RegMap $ + applySubstitutionRegEntries sym fixpoint_func_substitution (C.regMap reg_map) + + res_mem_impl <- storeMemJoinVariables bak + header_mem_impl + (fixpointMemSubstitution fixpoint_record) + fixpoint_func_substitution + + (_ :: ()) <- case loop_bound of + LoopIndexBound{ index = loop_index, stop = loop_stop } -> do + let loop_index' = MapF.findWithDefault loop_index loop_index fixpoint_func_substitution + index_bound_condition <- loopIndexBoundCondition sym loop_index' loop_stop + C.addAssumption bak $ C.GenericAssumption loc "" index_bound_condition + index_start_step_condition <- loopIndexStartStepCondition sym $ LoopIndexBound + { index = loop_index' + , start = start loop_bound + , stop = loop_stop + , step = step loop_bound + } + C.addAssumption bak $ C.GenericAssumption loc "" index_start_step_condition + + writeIORef fixpoint_state_ref $ + AfterFixpoint + fixpoint_record{ fixpointSubstitution = res_substitution } + loop_bound + + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & (C.stateCrucibleFrame . C.frameRegs) .~ res_reg_map + & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: CheckFixpoint"] + + AfterFixpoint{} -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["AfterFixpoint"] + + +data MaybePausedFrameTgtId f where + JustPausedFrameTgtId :: C.Some (C.BlockID b) -> MaybePausedFrameTgtId (C.CrucibleLang b r) + NothingPausedFrameTgtId :: MaybePausedFrameTgtId f + +pausedFrameTgtId :: C.PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f +pausedFrameTgtId C.PausedFrame{ resume = resume } = case resume of + C.ContinueResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id + C.CheckMergeResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id + _ -> NothingPausedFrameTgtId diff --git a/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs @@ -0,0 +1,1211 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.SimpleLoopInvariant +-- Description : Execution feature to perform verification of simply +-- structured loops via invariants. +-- Copyright : (c) Galois, Inc 2022 +-- License : BSD3 +-- Stability : provisional +-- +-- +-- This module provides an execution feature that can be installed +-- into the Crucible simulator which facilitates reasoning about +-- certain kinds of loops by using loop invariants instead of +-- requiring that loops symbolically terminate. In order for this +-- feature to work, the loop in question needs to be +-- single-entry/single-exit, and needs to have a constant memory +-- footprint on each loop iteration (except that memory regions backed +-- by SMT arrays are treated as a whole, so loops can write into +-- different regions of an SMT-array memory region on different +-- iterations). In addition, loop-involved memory writes must be +-- sufficiently concrete that we can determine their region values, +-- and writes to the same region value must have concrete distances +-- from each other, so we can determine if/when they alias. +-- +-- To set up a loop invariant for a loop, you must specify which CFG the +-- loop is in, indicate which loop (of potentially several) in the CFG +-- is the one of interest, and give a function that is used to construct +-- the statement of the loop invariant. When given a CFG, the execution +-- feature computes a weak topological ordering to find the loops in +-- the program; the number given by the user selects which of these to +-- install the invariant for. +-- +-- At runtime, we will interrupt execution when the loop head is +-- reached; at this point we will record the values of the memory and +-- the incoming local variables. Then, we will begin a series of +-- "hypothetical" executions of the loop body and track how the memory +-- and local variables are modified by the loop body. On each +-- iteration where we find a difference, we replace the local or +-- memory region with a fresh "join variable" which represents the +-- unknown value of a loop-carried dependency. We continue this process +-- until we reach a fixpoint; then we will have captured all the locations +-- that are potentially of interest for the loop invariant. +-- +-- Once we have found all the loop-carried dependencies, we assert +-- that the loop invariant holds on the initial values upon entry to the +-- loop. Then, we set up another execution starting from the loop head +-- where we first assume the loop invariant over the join variables +-- invented earlier, and begin execution again. In this mode, when we +-- reach the loop head once more, we assert the loop invariant on the +-- computed values and abort execution along that path. Paths exiting +-- the loop continue as normal. +-- +-- Provided the user suppiles an appropriate loop invarant function +-- and can discharge all the generated proof obligations, this procedure +-- should result in a sound proof of partial correctness for the function +-- in question. +-- +-- This whole procedure has some relatively fragile elements that are +-- worth calling out. First, specifying which loop you want to reason +-- about may require some trial-and-error, the WTO ordering might not +-- directly correspond to what is seen in the source code. The most +-- reliable way to select the right loop is to ensure there is only +-- one loop of interest in a given function, and use loop index 0. +-- The other fragility has to do with the discovery of loop-carried +-- dependencies. The number and order of values that are supplied to +-- the loop invariant depend on the internal details of the compiler +-- and simulator, so the user may have to spend some time and effort +-- to discover what the values appearing in the invariant correspond +-- to. This process may well be quite sensitive to changes in the +-- source code. +-- +-- Limitiations: currently, this feature is restricted to 64-bit code. +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Lang.Crucible.LLVM.SimpleLoopInvariant + ( InvariantEntry(..) + , InvariantPhase(..) + , simpleLoopInvariant + ) where + +import Control.Lens +import Control.Monad (forM, unless, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Except (ExceptT, MonadError(..), runExceptT) +import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT) +import Control.Monad.State (MonadState(..), StateT(..)) +import Data.Foldable +import qualified Data.IntMap as IntMap +import Data.IORef +import qualified Data.List as List +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified System.IO +import Numeric.Natural +import Prettyprinter (pretty) + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Map (MapF) +import Data.Parameterized.NatRepr +import Data.Parameterized.TraversableF +import Data.Parameterized.TraversableFC + +import qualified What4.Config as W4 +import qualified What4.Interface as W4 +import qualified What4.ProgramLoc as W4 + +import qualified Lang.Crucible.Analysis.Fixpoint.Components as C +import qualified Lang.Crucible.Backend as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.CFG.Extension as C +import qualified Lang.Crucible.Panic as C +import qualified Lang.Crucible.Simulator.CallFrame as C +import qualified Lang.Crucible.Simulator.EvalStmt as C +import qualified Lang.Crucible.Simulator.ExecutionTree as C +import qualified Lang.Crucible.Simulator.GlobalState as C +import qualified Lang.Crucible.Simulator.Operations as C +import qualified Lang.Crucible.Simulator.RegMap as C +import qualified Lang.Crucible.Simulator as C + +import qualified Lang.Crucible.LLVM.Bytes as C +import qualified Lang.Crucible.LLVM.DataLayout as C +import qualified Lang.Crucible.LLVM.MemModel as C +import qualified Lang.Crucible.LLVM.MemModel.MemLog as C hiding (Mem) +import qualified Lang.Crucible.LLVM.MemModel.Pointer as C +import qualified Lang.Crucible.LLVM.MemModel.Type as C + + +-- | A datatype describing the reason we are building an instance +-- of the loop invariant. +data InvariantPhase + = InitialInvariant + | HypotheticalInvariant + | InductiveInvariant + deriving (Eq, Ord, Show) + +-- | When live loop-carried dependencies are discovered as we traverse +-- a loop body, new "widening" variables are introduced to stand in +-- for those locations. When we introduce such a varible, we +-- capture what value the variable had when we entered the loop (the +-- \"header\" value); this is essentially the initial value of the +-- variable. We also compute what value the variable should take on +-- its next iteration assuming the loop doesn't exit and executes +-- along its backedge. This \"body\" value will be computed in +-- terms of the the set of all discovered live variables so far. +-- We know we have reached fixpoint when we don't need to introduce +-- any more fresh widening variables, and the body values for each +-- variable are stable across iterations. +data InvariantEntry sym tp = + InvariantEntry + { headerValue :: W4.SymExpr sym tp + , bodyValue :: W4.SymExpr sym tp + } + +instance OrdF (W4.SymExpr sym) => OrdF (InvariantEntry sym) where + compareF x y = case compareF (headerValue x) (headerValue y) of + LTF -> LTF + EQF -> compareF (bodyValue x) (bodyValue y) + GTF -> GTF + +instance OrdF (InvariantEntry sym) => W4.TestEquality (InvariantEntry sym) where + testEquality x y = orderingF_refl (compareF x y) + +-- | This datatype captures the state machine that progresses as we +-- attempt to compute a loop invariant for a simple structured loop. +data FixpointState p sym ext rtp blocks + -- | We have not yet encoundered the loop head + = BeforeFixpoint + + -- | We have encountered the loop head at least once, and are in the process + -- of converging to an inductive representation of the live variables + -- in the loop. + | ComputeFixpoint C.FrameIdentifier (FixpointRecord p sym ext rtp blocks) + + -- | We have found an inductively-strong representation of the live variables + -- of the loop. We are now executing the from the loop head one final time + -- to produce the proof obligations arising from the body of the loop, + -- the main inductive loop invariant obligation, and any obligations arising + -- from code following the loop exit. + | CheckFixpoint (FixpointRecord p sym ext rtp blocks) + + +-- | Data about the loop that we incrementally compute as we approach fixpoint. +data FixpointRecord p sym ext rtp blocks = forall args r. + FixpointRecord + { + -- | Block identifier of the head of the loop + fixpointBlockId :: C.BlockID blocks args + + -- | Map from introduced widening variables to prestate value before the loop starts, + -- and to the value computed in a single loop iteration, assuming we return to the + -- loop header. These variables may appear only in either registers or memory. + , fixpointSubstitution :: VariableSubst sym + + -- | The memory subsitution describes where the loop-carried dependencies live in the + -- memory. + , fixpointMemSubstitution :: MemorySubstitution sym + + -- | Prestate values of the Crucible registers when the loop header is first encountered. + , fixpointRegMap :: C.RegMap sym args + + -- | The sim state of the simulator when we first encounter the loop header. + , fixpointInitialSimState :: C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) + + -- | External constants appearing in the expressions computed by the loop. These will be passed + -- into the loop invariant as additional parameters. + , fixpointImplicitParams :: [Some (W4.SymExpr sym)] + + -- | A special memory region number that does not correspond to any valid block. + -- This is intended to model values the block portion of bitvector values that + -- get clobbered by the loop body, but do not represent loop-carried dependencies. + , fixpointHavocBlock :: W4.SymNat sym + } + +-- | A variable substitution is used to track metadata regarding the discovered +-- loop-carried dependencies of a loop. +data VariableSubst sym = + VarSubst + { varSubst :: MapF (W4.SymExpr sym) (InvariantEntry sym) + -- ^ The @varSubst@ associates to each "join variable" an @InvariantEntry@, + -- that descibes the initial value the variable had, and the value computed + -- for it after a loop iteration. + + , varHavoc :: MapF (W4.SymExpr sym) (Const ()) + -- ^ The @varHavoc@ map is essentially just a set of "join variables" for which + -- we were not able to compute a coherent value across the loop boundary. + -- Such variables are considered to be "junk" at the beginning of the loop, + -- and do not participate in the loop invariant. This usually arises from + -- temporary scratch space used in the loop body. + } + + +-- | A memory region is used to describe a contiguous sequence of bytes +-- which is of known size, and which is at a known, concrete, offset +-- from a "master" offset. In a given regualar memory block, these +-- regions are required to be disjoint. +data MemoryRegion sym = + forall w. (1 <= w) => + MemoryRegion + { regionOffset :: BV.BV 64 -- ^ Offset of the region, from the base pointer + , regionSize :: C.Bytes -- ^ Length of the memory region, in bytes + , regionStorage :: C.StorageType -- ^ The storage type used to write to this region + , regionJoinVar :: W4.SymBV sym w -- ^ The join variable representing this region + } + +-- | Memory block data are used to describe where in memory +-- loop-carried dependencies are. They may either be +-- "regular" blocks or "array" blocks. A regular block +-- consists of a collection of regions of known size, each +-- of which is at some concretely-known offset from a single +-- master offset value inside the LLVM memory region. +-- An array block consists of an entire LLVM memory region +-- that is backed by an SMT array. +data MemoryBlockData sym where + RegularBlock :: + W4.SymBV sym 64 + {- ^ A potentially symbolic base pointer/offset. All the + offsets in this region are required to be at a concrete + distance from this base pointer. -} -> + Map Natural (MemoryRegion sym) + {- ^ mapping from offset values to regions -} -> + MemoryBlockData sym + + ArrayBlock :: + W4.SymExpr sym ArrayTp {- ^ array join variable -} -> + W4.SymBV sym 64 {- ^ length of the allocation -} -> + MemoryBlockData sym + +type ArrayTp = W4.BaseArrayType (C.EmptyCtx C.::> W4.BaseBVType 64) (W4.BaseBVType 8) + +-- | A memory substitution gives memory block data for +-- concrete memory region numbers of writes occurring +-- in the loop body. This is used to determine where +-- in memory the relevant values are that need to be +-- passed to the loop invariant. +newtype MemorySubstitution sym = + MemSubst + { memSubst :: Map Natural (MemoryBlockData sym) + {- ^ Mapping from block numbers to block data -} + } + + +fixpointRecord :: + FixpointState p sym ext rtp blocks -> + Maybe (FixpointRecord p sym ext rtp blocks) +fixpointRecord BeforeFixpoint = Nothing +fixpointRecord (ComputeFixpoint _ r) = Just r +fixpointRecord (CheckFixpoint r) = Just r + + +-- The fixpoint monad is used to ease the process of computing variable widenings +-- and such. The included "SymNat" is a memory region number guaranteed not +-- to be a valid memory region; it is used to implement "havoc" registers that +-- we expect to be junk/scratch space across the loop boundary. +-- The state component tracks the variable substitution we are computing. +newtype FixpointMonad sym a = + FixpointMonad (ReaderT (W4.SymNat sym) (StateT (VariableSubst sym) IO) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadFail) + +deriving instance MonadReader (W4.SymNat sym) (FixpointMonad sym) +deriving instance MonadState (VariableSubst sym) (FixpointMonad sym) + +runFixpointMonad :: + W4.SymNat sym -> + VariableSubst sym -> + FixpointMonad sym a -> + IO (a, VariableSubst sym) +runFixpointMonad havoc_blk subst (FixpointMonad m) = + runStateT (runReaderT m havoc_blk) subst + +joinRegEntries :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + sym -> + Ctx.Assignment (C.RegEntry sym) ctx -> + Ctx.Assignment (C.RegEntry sym) ctx -> + FixpointMonad sym (Ctx.Assignment (C.RegEntry sym) ctx) +joinRegEntries sym = Ctx.zipWithM (joinRegEntry sym) + +joinRegEntry :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + sym -> + C.RegEntry sym tp -> + C.RegEntry sym tp -> + FixpointMonad sym (C.RegEntry sym tp) +joinRegEntry sym left right = do + subst <- get + case C.regType left of + C.LLVMPointerRepr w + + -- TODO! This is a "particularly guesome hack" it would be nice to find some better + -- way to handle this situation. + -- special handling for "don't care" registers coming from Macaw + | List.isPrefixOf "cmacaw_reg" (show $ W4.printSymNat $ C.llvmPointerBlock (C.regValue left)) + , List.isPrefixOf "cmacaw_reg" (show $ W4.printSymExpr $ C.llvmPointerOffset (C.regValue left)) -> do + -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: cmacaw_reg" + return left + + | C.llvmPointerBlock (C.regValue left) == C.llvmPointerBlock (C.regValue right) + , Nothing <- MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varHavoc subst) -> do + -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr" + if isJust (W4.testEquality (C.llvmPointerOffset (C.regValue left)) (C.llvmPointerOffset (C.regValue right))) + then do + -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: left == right" + return left + else case MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varSubst subst) of + Just join_entry -> do + -- liftIO $ ?logMessage $ + -- "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: Just: " + -- ++ show (W4.printSymExpr $ bodyValue join_entry) + -- ++ " -> " + -- ++ show (W4.printSymExpr $ C.llvmPointerOffset (C.regValue right)) + put $ subst{ varSubst = + MapF.insert + (C.llvmPointerOffset (C.regValue left)) + (join_entry { bodyValue = C.llvmPointerOffset (C.regValue right) }) + (varSubst subst) } + return left + Nothing -> do + liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr: Nothing" + join_variable <- liftIO $ W4.freshConstant sym + (W4.safeSymbol "reg_join_var") (W4.BaseBVRepr w) + let join_entry = InvariantEntry + { headerValue = C.llvmPointerOffset (C.regValue left) + , bodyValue = C.llvmPointerOffset (C.regValue right) + } + put $ subst{ varSubst = MapF.insert join_variable join_entry (varSubst subst) } + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) join_variable + + | otherwise -> do + liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: LLVMPointerRepr, unequal blocks!" + havoc_blk <- ask + case MapF.lookup (C.llvmPointerOffset (C.regValue left)) (varSubst subst) of + Just _ -> do + -- widening varible already present in the var substitition. + -- we need to remove it, and add it to the havoc map instead + put subst { varSubst = MapF.delete (C.llvmPointerOffset (C.regValue left)) (varSubst subst) + , varHavoc = MapF.insert (C.llvmPointerOffset (C.regValue left)) (Const ()) (varHavoc subst) + } + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer havoc_blk (C.llvmPointerOffset (C.regValue left)) + + Nothing -> do + havoc_var <- liftIO $ W4.freshConstant sym (W4.safeSymbol "havoc_var") (W4.BaseBVRepr w) + put subst{ varHavoc = MapF.insert havoc_var (Const ()) (varHavoc subst) } + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer havoc_blk havoc_var + + C.BoolRepr + | List.isPrefixOf "cmacaw" (show $ W4.printSymExpr $ C.regValue left) -> do + liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: cmacaw_reg" + return left + | otherwise -> do + -- liftIO $ ?logMessage $ + -- "SimpleLoopInvariant.joinRegEntry: BoolRepr:" + -- ++ show (W4.printSymExpr $ C.regValue left) + -- ++ " \\/ " + -- ++ show (W4.printSymExpr $ C.regValue right) + join_varaible <- liftIO $ W4.freshConstant sym (W4.safeSymbol "reg_join_var") W4.BaseBoolRepr + return $ C.RegEntry C.BoolRepr join_varaible + + C.StructRepr field_types -> do + -- liftIO $ ?logMessage "SimpleLoopInvariant.joinRegEntry: StructRepr" + C.RegEntry (C.regType left) <$> fmapFC (C.RV . C.regValue) <$> joinRegEntries sym + (Ctx.generate (Ctx.size field_types) $ \i -> + C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue left) Ctx.! i) + (Ctx.generate (Ctx.size field_types) $ \i -> + C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue right) Ctx.! i) + _ -> fail $ "SimpleLoopInvariant.joinRegEntry: unsupported type: " ++ show (C.regType left) + + +applySubstitutionRegEntries :: + C.IsSymInterface sym => + sym -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + Ctx.Assignment (C.RegEntry sym) ctx -> + Ctx.Assignment (C.RegEntry sym) ctx +applySubstitutionRegEntries sym substitution = fmapFC (applySubstitutionRegEntry sym substitution) + +applySubstitutionRegEntry :: + C.IsSymInterface sym => + sym -> + (MapF (W4.SymExpr sym) (W4.SymExpr sym)) -> + C.RegEntry sym tp -> + C.RegEntry sym tp +applySubstitutionRegEntry sym substitution entry = case C.regType entry of + C.LLVMPointerRepr{} -> + entry + { C.regValue = C.LLVMPointer + (C.llvmPointerBlock (C.regValue entry)) + (MapF.findWithDefault + (C.llvmPointerOffset (C.regValue entry)) + (C.llvmPointerOffset (C.regValue entry)) + substitution) + } + C.BoolRepr -> + entry + C.StructRepr field_types -> + entry + { C.regValue = fmapFC (C.RV . C.regValue) $ + applySubstitutionRegEntries sym substitution $ + Ctx.generate (Ctx.size field_types) $ + \i -> C.RegEntry (field_types Ctx.! i) $ C.unRV $ (C.regValue entry) Ctx.! i + } + _ -> error $ unlines [ "SimpleLoopInvariant.applySubstitutionRegEntry" + , "unsupported type: " ++ show (C.regType entry) + ] + + +loadMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth 64, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + MemorySubstitution sym -> + IO (MapF (W4.SymExpr sym) (W4.SymExpr sym)) +loadMemJoinVariables bak mem (MemSubst subst) = do + let sym = C.backendGetSym bak + + vars <- forM (Map.toAscList subst) $ \ (blk, blkData) -> + case blkData of + ArrayBlock arr_var _sz -> + do base_ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 0) + res <- C.asMemAllocationArrayStore sym ?ptrWidth base_ptr (C.memImplHeap mem) + case res of + Nothing -> fail $ "Expected SMT array in memory image for block number: " ++ show blk + Just (_ok, arr, _len2) -> + -- TODO: we need to assert the load condition... + -- TODO? Should we assert the lengths match? + + return [MapF.Pair arr_var arr] + + RegularBlock basePtr offsetMap -> + forM (Map.toAscList offsetMap) $ + \ (_off , MemoryRegion{ regionJoinVar = join_var, regionStorage = storage_type, regionOffset = offBV }) -> + do blk' <- W4.natLit sym blk + off' <- W4.bvAdd sym basePtr =<< W4.bvLit sym ?ptrWidth offBV + let ptr = C.LLVMPointer blk' off' + val <- safeBVLoad sym mem ptr storage_type join_var C.noAlignment + return (MapF.Pair join_var val) + + return (MapF.fromList (concat vars)) + + +safeBVLoad :: + ( C.IsSymInterface sym, C.HasPtrWidth wptr, C.HasLLVMAnn sym + , ?memOpts :: C.MemOptions, 1 <= w ) => + sym -> + C.MemImpl sym -> + C.LLVMPtr sym wptr {- ^ pointer to load from -} -> + C.StorageType {- ^ type of value to load -} -> + W4.SymBV sym w {- ^ default value to return -} -> + C.Alignment {- ^ assumed pointer alignment -} -> + IO (C.RegValue sym (C.BVType w)) +safeBVLoad sym mem ptr st def align = + do let w = W4.bvWidth def + pval <- C.loadRaw sym mem ptr st align + case pval of + C.Err _ -> return def + C.NoErr p v -> + do v' <- C.unpackMemValue sym (C.LLVMPointerRepr w) v + p0 <- W4.natEq sym (C.llvmPointerBlock v') =<< W4.natLit sym 0 + p' <- W4.andPred sym p p0 + W4.bvIte sym p' (C.llvmPointerOffset v') def + +storeMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth 64, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + MemorySubstitution sym -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + IO (C.MemImpl sym) +storeMemJoinVariables bak mem (MemSubst mem_subst) eq_subst = + foldlM + (\mem_acc (blk, blk_data) -> + case blk_data of + RegularBlock basePtr off_map -> + foldlM (writeMemRegion blk basePtr) mem_acc (Map.toAscList off_map) + ArrayBlock arr len -> + do base_ptr <- C.LLVMPointer <$> W4.natLit sym blk <*> W4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 0) + let arr' = MapF.findWithDefault arr arr eq_subst + C.doArrayStore bak mem_acc base_ptr C.noAlignment arr' len) + mem + (Map.toAscList mem_subst) + + where + sym = C.backendGetSym bak + + writeMemRegion blk basePtr mem_acc (_off, MemoryRegion{ regionJoinVar = join_var, regionStorage = storage_type, regionOffset = offBV }) = + do blk' <- W4.natLit sym blk + off' <- W4.bvAdd sym basePtr =<< W4.bvLit sym ?ptrWidth offBV + let ptr = C.LLVMPointer blk' off' + C.doStore bak mem_acc ptr (C.LLVMPointerRepr $ W4.bvWidth join_var) storage_type C.noAlignment =<< + C.llvmPointer_bv sym (MapF.findWithDefault join_var join_var eq_subst) + + + +dropMemStackFrame :: C.IsSymInterface sym => C.MemImpl sym -> (C.MemImpl sym, C.MemAllocs sym, C.MemWrites sym) +dropMemStackFrame mem = case (C.memImplHeap mem) ^. C.memState of + (C.StackFrame _ _ _ (a, w) s) -> ((mem { C.memImplHeap = (C.memImplHeap mem) & C.memState .~ s }), a, w) + _ -> C.panic "SimpleLoopInvariant.dropMemStackFrame" ["not a stack frame:", show (C.ppMem $ C.memImplHeap mem)] + + +filterSubstitution :: + C.IsSymInterface sym => + sym -> + VariableSubst sym -> + VariableSubst sym +filterSubstitution sym (VarSubst substitution havoc) = + -- TODO: fixpoint + let uninterp_constants = foldMapF + (Set.map (C.mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . bodyValue) + substitution + in + VarSubst + (MapF.filterWithKey (\variable _entry -> Set.member (C.Some variable) uninterp_constants) substitution) + havoc + +-- find widening variables that are actually the same (up to syntactic equality) +-- and can be substituted for each other +uninterpretedConstantEqualitySubstitution :: + forall sym . + C.IsSymInterface sym => + sym -> + VariableSubst sym -> + (VariableSubst sym, MapF (W4.SymExpr sym) (W4.SymExpr sym)) +uninterpretedConstantEqualitySubstitution _sym (VarSubst substitution havoc) = + let reverse_substitution = MapF.foldlWithKey' + (\accumulator variable entry -> MapF.insert entry variable accumulator) + MapF.empty + substitution + uninterpreted_constant_substitution = fmapF + (\entry -> fromJust $ MapF.lookup entry reverse_substitution) + substitution + normal_substitution = MapF.filterWithKey + (\variable _entry -> + Just Refl == W4.testEquality variable (fromJust $ MapF.lookup variable uninterpreted_constant_substitution)) + substitution + in + (VarSubst normal_substitution havoc, uninterpreted_constant_substitution) + + +-- | Given the WTO analysis results, find the nth loop. +-- Return the identifier of the loop header, and a list of all the blocks +-- that are part of the loop body. It is at this point that we check +-- that the loop has the necessary properties; there must be a single +-- entry point to the loop, and it must have a single back-edge. Otherwise, +-- the analysis will not work correctly. +computeLoopBlocks :: forall ext blocks init ret k. (k ~ C.Some (C.BlockID blocks)) => + C.CFG ext blocks init ret -> + Integer -> + IO (k, [k]) +computeLoopBlocks cfg loopNum = + case List.genericDrop loopNum (Map.toList loop_map) of + [] -> fail ("Did not find " ++ show loopNum ++ " loop headers") + (p:_) -> do checkSingleEntry p + checkSingleBackedge p + return p + + where + -- There should be exactly one block which is not part of the loop body that + -- can jump to @hd@. + checkSingleEntry :: (k,[k]) -> IO () + checkSingleEntry (hd, body) = + case filter (\x -> not (elem x body) && elem hd (C.cfgSuccessors cfg x)) allReachable of + [_] -> return () + _ -> fail "SimpleLoopInvariant feature requires a single-entry loop!" + + -- There should be exactly on block in the loop body which can jump to @hd@. + checkSingleBackedge :: (k,[k]) -> IO () + checkSingleBackedge (hd, body) = + case filter (\x -> elem hd (C.cfgSuccessors cfg x)) body of + [_] -> return () + _ -> fail "SimpleLoopInvariant feature requires a loop with a single backedge!" + + flattenWTOComponent = \case + C.SCC C.SCCData{..} -> wtoHead : concatMap flattenWTOComponent wtoComps + C.Vertex v -> [v] + + loop_map = Map.fromList $ mapMaybe + (\case + C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps) + C.Vertex{} -> Nothing) + wto + + allReachable = concatMap flattenWTOComponent wto + + wto = C.cfgWeakTopologicalOrdering cfg + + +-- | This execution feature is designed to allow a limited form of +-- verification for programs with unbounded looping structures. +-- +-- It is currently highly experimental and has many limititations. +-- Most notably, it only really works properly for functions +-- consisting of a single, non-nested loop with a single exit point. +-- Moreover, the loop must have an indexing variable that counts up +-- from a starting point by a fixed stride amount. +-- +-- Currently, these assumptions about the loop structure are not +-- checked. +-- +-- The basic use case here is for verifying functions that loop +-- through an array of data of symbolic length. This is done by +-- providing a \"fixpoint function\" which describes how the live +-- values in the loop at an arbitrary iteration are used to compute +-- the final values of those variables before execution leaves the +-- loop. The number and order of these variables depends on +-- internal details of the representation, so is relatively fragile. +simpleLoopInvariant :: + forall sym ext p rtp blocks init ret . + (C.IsSymInterface sym, C.IsSyntaxExtension ext, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + sym -> + Integer {- ^ which of the discovered loop heads to install a loop invariant onto -} -> + C.CFG ext blocks init ret {- ^ The function we want to verify -} -> + C.GlobalVar C.Mem {- ^ global variable representing memory -} -> + (InvariantPhase -> [Some (W4.SymExpr sym)] -> MapF (W4.SymExpr sym) (InvariantEntry sym) -> IO (W4.Pred sym)) -> + IO (C.ExecutionFeature p sym ext rtp) +simpleLoopInvariant sym loopNum cfg@C.CFG{..} mem_var loop_invariant = do + -- TODO, can we lift this restriction to 64-bits? I don't think there + -- is anything fundamental about it. + let ?ptrWidth = knownNat @64 + + verbSetting <- W4.getOptionSetting W4.verbosity $ W4.getConfiguration sym + verb <- fromInteger <$> W4.getOpt verbSetting + + (loop_header, loop_body_blocks) <- computeLoopBlocks cfg loopNum + + fixpoint_state_ref <- newIORef @(FixpointState p sym ext rtp blocks) BeforeFixpoint + + --putStrLn "Setting up simple loop fixpoints feature." + --putStrLn ("WTO: " ++ show (C.cfgWeakTopologicalOrdering cfg)) + + return $ C.ExecutionFeature $ \exec_state -> do + let ?logMessage = \msg -> when (verb >= (3 :: Natural)) $ do + let h = C.printHandle $ C.execStateContext exec_state + System.IO.hPutStrLn h msg + System.IO.hFlush h + + fixpoint_state <- readIORef fixpoint_state_ref + C.withBackend (C.execStateContext exec_state) $ \bak -> + case exec_state of + C.RunningState (C.RunBlockStart block_id) sim_state + | C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + + -- make sure the types match + , Just Refl <- W4.testEquality + (fmapFC C.blockInputs cfgBlockMap) + (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + + -- is this state at thea loop header? + , C.Some block_id == loop_header -> + + advanceFixpointState bak mem_var loop_invariant block_id sim_state fixpoint_state fixpoint_state_ref + + | otherwise -> do + ?logMessage $ "SimpleLoopInvariant: RunningState: RunBlockStart: " ++ show block_id ++ " " ++ show (C.frameHandle (sim_state ^. C.stateCrucibleFrame)) + return C.ExecutionFeatureNoChange + + C.SymbolicBranchState branch_condition true_frame false_frame _target sim_state + | Just _fixpointRecord <- fixpointRecord fixpoint_state + , JustPausedFrameTgtId true_frame_some_block_id <- pausedFrameTgtId true_frame + , JustPausedFrameTgtId false_frame_some_block_id <- pausedFrameTgtId false_frame + , C.SomeHandle cfgHandle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + , Just Refl <- W4.testEquality + (fmapFC C.blockInputs cfgBlockMap) + (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + , elem true_frame_some_block_id loop_body_blocks /= + elem false_frame_some_block_id loop_body_blocks -> do + + (loop_condition, inside_loop_frame) <- + if elem true_frame_some_block_id loop_body_blocks + then + return (branch_condition, true_frame) + else do + not_branch_condition <- W4.notPred sym branch_condition + return (not_branch_condition, false_frame) + + case fixpoint_state of + BeforeFixpoint -> C.panic "SimpleLoopInvariant.simpleLoopInvariant:" ["BeforeFixpoint"] + + ComputeFixpoint _assumeIdent _fixpoint_record -> do + -- continue in the loop + ?logMessage $ "SimpleLoopInvariant: SymbolicBranchState: ComputeFixpoint" + + loc <- W4.getCurrentProgramLoc sym + C.addAssumption bak $ C.BranchCondition loc (C.pausedLoc inside_loop_frame) loop_condition + + C.ExecutionFeatureNewState <$> + runReaderT + (C.resumeFrame (C.forgetPostdomFrame inside_loop_frame) $ sim_state ^. (C.stateTree . C.actContext)) + sim_state + + CheckFixpoint _fixpoint_record -> do + ?logMessage $ "SimpleLoopInvariant: SymbolicBranchState: CheckFixpoint" + + return C.ExecutionFeatureNoChange + + _ -> return C.ExecutionFeatureNoChange + + +advanceFixpointState :: + forall sym bak ext p rtp blocks r args . + (C.IsSymBackend sym bak, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) => + bak -> + C.GlobalVar C.Mem -> + (InvariantPhase -> [Some (W4.SymExpr sym)] -> MapF (W4.SymExpr sym) (InvariantEntry sym) -> IO (W4.Pred sym)) -> + C.BlockID blocks args -> + C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) -> + FixpointState p sym ext rtp blocks -> + IORef (FixpointState p sym ext rtp blocks) -> + IO (C.ExecutionFeatureResult p sym ext rtp) + +advanceFixpointState bak mem_var loop_invariant block_id sim_state fixpoint_state fixpoint_state_ref = do + let ?ptrWidth = knownNat @64 + let sym = C.backendGetSym bak + loc <- W4.getCurrentProgramLoc sym + case fixpoint_state of + BeforeFixpoint -> do + ?logMessage $ "SimpleLoopInvariant: RunningState: BeforeFixpoint -> ComputeFixpoint " ++ show block_id ++ " " ++ show (pretty (W4.plSourceLoc loc)) + assumption_frame_identifier <- C.pushAssumptionFrame bak + let mem_impl = case C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) of + Just m -> m + Nothing -> C.panic "SimpleLoopInvariant.advanceFixpointState" + ["LLVM Memory variable not found!"] + let res_mem_impl = mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" $ C.memImplHeap mem_impl } + +-- ?logMessage $ "SimpleLoopInvariant: start memory\n" ++ (show (C.ppMem (C.memImplHeap mem_impl))) + + -- Get a fresh block value that doesn't correspond to any valid memory region + havoc_blk <- W4.natLit sym =<< C.nextBlock (C.memImplBlockSource mem_impl) + + writeIORef fixpoint_state_ref $ ComputeFixpoint assumption_frame_identifier $ + FixpointRecord + { fixpointBlockId = block_id + , fixpointSubstitution = VarSubst MapF.empty MapF.empty + , fixpointRegMap = sim_state ^. (C.stateCrucibleFrame . C.frameRegs) + , fixpointMemSubstitution = MemSubst mempty + , fixpointInitialSimState = sim_state + , fixpointImplicitParams = [] + , fixpointHavocBlock = havoc_blk + } + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + ComputeFixpoint assumeFrame fixpoint_record + | FixpointRecord { fixpointRegMap = reg_map + , fixpointInitialSimState = initSimState + , fixpointHavocBlock = havoc_blk + } + <- fixpoint_record + , Just Refl <- W4.testEquality + (fmapFC C.regType $ C.regMap reg_map) + (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do + + + ?logMessage $ "SimpleLoopInvariant: RunningState: ComputeFixpoint: " ++ show block_id + _ <- C.popAssumptionFrameAndObligations bak assumeFrame + + let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) + let (header_mem_impl, mem_allocs, mem_writes) = dropMemStackFrame body_mem_impl + when (C.sizeMemAllocs mem_allocs /= 0) $ + fail "SimpleLoopInvariant: unsupported memory allocation in loop body." + + -- widen the inductive condition + ((join_reg_map,mem_substitution), join_substitution) <- + runFixpointMonad havoc_blk (fixpointSubstitution fixpoint_record) $ + do join_reg_map <- joinRegEntries sym + (C.regMap reg_map) + (C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) + mem_substitution <- computeMemSubstitution sym fixpoint_record mem_writes + return (join_reg_map, mem_substitution) + + -- check if we are done; if we did not introduce any new variables, we don't have to widen any more + if MapF.keys (varSubst join_substitution) == + MapF.keys (varSubst (fixpointSubstitution fixpoint_record)) + + -- we found the fixpoint, get ready to wrap up + then do + ?logMessage $ + "SimpleLoopInvariant: RunningState: ComputeFixpoint -> CheckFixpoint " + ++ " " ++ show (pretty (W4.plSourceLoc loc)) + -- we have delayed populating the main substitution map with + -- memory variables, so we have to do that now + + header_mem_substitution <- loadMemJoinVariables bak header_mem_impl $ + fixpointMemSubstitution fixpoint_record + body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ + fixpointMemSubstitution fixpoint_record + + -- try to unify widening variables that have the same values + let (normal_substitution, equality_substitution) = + uninterpretedConstantEqualitySubstitution sym $ + -- drop variables that don't appear along some back edge (? understand this better) + filterSubstitution sym $ + join_substitution + { varSubst = + MapF.union (varSubst join_substitution) $ + -- this implements zip, because the two maps have the same keys + MapF.intersectWithKeyMaybe + (\_k x y -> Just $ InvariantEntry{ headerValue = x, bodyValue = y }) + header_mem_substitution + body_mem_substitution + } +-- ?logMessage $ "normal_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList (varSubst normal_substitution)) +-- ?logMessage $ "equality_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList equality_substitution) +-- ?logMessage $ "havoc variables: " ++ show (map (\(MapF.Pair x _) -> W4.printSymExpr x) $ MapF.toList (varHavoc normal_substitution)) + + -- unify widening variables in the register subst + let res_reg_map = applySubstitutionRegEntries sym equality_substitution join_reg_map + + -- unify widening variables in the memory subst + res_mem_impl <- storeMemJoinVariables + bak + header_mem_impl + mem_substitution + equality_substitution + + -- == compute the list of "implicit parameters" that are relevant == + let implicit_params = Set.toList $ + Set.difference + (foldMap + (\ (MapF.Pair _ e) -> + -- filter out the special "noSatisfyingWrite" boolean constants + -- that are generated as part of the LLVM memory model + Set.filter ( \ (C.Some x) -> + not (List.isPrefixOf "cnoSatisfyingWrite" + (show $ W4.printSymExpr x))) $ + Set.map (\ (C.Some x) -> C.Some (W4.varExpr sym x)) $ + (W4.exprUninterpConstants sym (bodyValue e))) + (MapF.toList (varSubst normal_substitution))) + (Set.fromList (MapF.keys (varSubst normal_substitution))) + + ?logMessage $ unlines $ + ["Implicit parameters!"] ++ + map (\ (C.Some x) -> show (W4.printSymExpr x)) implicit_params + + -- == assert the loop invariant on the initial values == + + -- build a map where the current value is equal to the initial value + let init_state_map = MapF.map (\e -> e{ bodyValue = headerValue e }) + (varSubst normal_substitution) + -- construct the loop invariant + initial_loop_invariant <- loop_invariant InitialInvariant implicit_params init_state_map + -- assert the loop invariant as an obligation + C.addProofObligation bak + $ C.LabeledPred initial_loop_invariant + $ C.SimError loc "initial loop invariant" + + -- == assume the loop invariant on the arbitrary state == + + -- build a map where the current value is equal to the widening variable + let hyp_state_map = MapF.mapWithKey (\k e -> e{ bodyValue = k }) + (varSubst normal_substitution) + -- construct the loop invariant to assume at the loop head + hypothetical_loop_invariant <- loop_invariant HypotheticalInvariant implicit_params hyp_state_map + -- assume the loop invariant + C.addAssumption bak + $ C.GenericAssumption loc "loop head invariant" + hypothetical_loop_invariant + + -- == set up the state with arbitrary values to run the loop body == + + writeIORef fixpoint_state_ref $ + CheckFixpoint + FixpointRecord + { fixpointBlockId = block_id + , fixpointSubstitution = normal_substitution + , fixpointRegMap = C.RegMap res_reg_map + , fixpointMemSubstitution = mem_substitution + , fixpointInitialSimState = initSimState + , fixpointImplicitParams = implicit_params + , fixpointHavocBlock = havoc_blk + } + + -- Continue running from the loop header starting from an arbitrary state satisfying + -- the loop invariant. + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + initSimState & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap res_reg_map + & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + else do + -- Otherwise, we are still working on finding all the loop-carried dependencies + ?logMessage $ + "SimpleLoopInvariant: RunningState: ComputeFixpoint: -> ComputeFixpoint" + assumption_frame_identifier <- C.pushAssumptionFrame bak + + -- write any new widening variables into memory state + res_mem_impl <- storeMemJoinVariables bak + (header_mem_impl { C.memImplHeap = C.pushStackFrameMem "fix" (C.memImplHeap header_mem_impl) }) + mem_substitution + MapF.empty + + writeIORef fixpoint_state_ref $ + ComputeFixpoint assumption_frame_identifier $ + FixpointRecord + { fixpointBlockId = block_id + , fixpointSubstitution = join_substitution + , fixpointRegMap = C.RegMap join_reg_map + , fixpointMemSubstitution = mem_substitution + , fixpointInitialSimState = initSimState + , fixpointImplicitParams = [] + , fixpointHavocBlock = havoc_blk + } + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + initSimState & (C.stateCrucibleFrame . C.frameRegs) .~ C.RegMap join_reg_map + & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + + | otherwise -> C.panic "SimpleLoopInvariant.simpleLoopInvariant" ["type mismatch: ComputeFixpoint"] + + CheckFixpoint fixpoint_record + | FixpointRecord { fixpointRegMap = reg_map } <- fixpoint_record + , Just Refl <- W4.testEquality + (fmapFC C.regType $ C.regMap reg_map) + (fmapFC C.regType $ C.regMap $ sim_state ^. (C.stateCrucibleFrame . C.frameRegs)) -> do + ?logMessage $ + "SimpleLoopInvariant: RunningState: " + ++ "CheckFixpoint" + ++ " -> " + ++ "AfterFixpoint" + ++ ": " + ++ show block_id + ++ " " ++ show (pretty (W4.plSourceLoc loc)) + + -- == assert the loop invariant and abort == + + let body_mem_impl = fromJust $ C.lookupGlobal mem_var (sim_state ^. C.stateGlobals) + + body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ fixpointMemSubstitution fixpoint_record + let res_substitution = MapF.mapWithKey + (\variable fixpoint_entry -> + fixpoint_entry + { bodyValue = MapF.findWithDefault (bodyValue fixpoint_entry) variable body_mem_substitution + }) + (varSubst (fixpointSubstitution fixpoint_record)) + -- ?logMessage $ "res_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList res_substitution) + + invariant_pred <- loop_invariant InductiveInvariant (fixpointImplicitParams fixpoint_record) res_substitution + C.addProofObligation bak $ C.LabeledPred invariant_pred $ C.SimError loc "loop invariant" + -- ?logMessage $ "fixpoint_func_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList fixpoint_func_substitution) + return $ C.ExecutionFeatureModifiedState $ C.AbortState (C.InfeasibleBranch loc) sim_state + + | otherwise -> C.panic "SimpleLoopInvariant.simpleLoopInvariant" ["type mismatch: CheckFixpoint"] + + + +constructMemSubstitutionCandidate :: forall sym. + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + C.IsSymInterface sym => + sym -> + C.MemWrites sym -> + IO (MemorySubstitution sym) +constructMemSubstitutionCandidate sym mem_writes = + case mem_writes of + C.MemWrites [C.MemWritesChunkIndexed mmm] -> + MemSubst <$> foldlM handleMemWrite mempty (List.concat $ IntMap.elems mmm) + + -- no writes occured in the body of the loop + C.MemWrites [] -> + return (MemSubst mempty) + + _ -> fail $ "SimpleLoopInvariant: not MemWritesChunkIndexed: " ++ + show (C.ppMemWrites mem_writes) + + where + updateOffsetMap :: + Natural -> + W4.SymBV sym 64 -> + C.LLVMPtr sym 64 -> + C.StorageType -> + Map Natural (MemoryRegion sym) -> + IO (Map Natural (MemoryRegion sym)) + updateOffsetMap blk basePtr ptr storage_type off_map = + do diff <- W4.bvSub sym (C.llvmPointerOffset ptr) basePtr + case W4.asBV diff of + Nothing -> + fail $ unlines + [ "SimpleLoopInvariant: incompatible base pointers for writes to a memory region " ++ show blk + , show (W4.printSymExpr basePtr) + , show (W4.printSymExpr (C.llvmPointerOffset ptr)) + ] + Just off -> + do let sz = C.typeEnd 0 storage_type + case Map.lookup (BV.asNatural off) off_map of + Just rgn + | regionSize rgn == sz -> return off_map + | otherwise -> + fail $ unlines + [ "Memory region written at incompatible storage types" + , show (regionStorage rgn) ++ " vs" ++ show storage_type + , show (C.ppPtr ptr) + ] + Nothing -> + case W4.mkNatRepr $ C.bytesToBits sz of + C.Some bv_width + | Just C.LeqProof <- W4.testLeq (W4.knownNat @1) bv_width -> do + join_var <- W4.freshConstant sym + (W4.safeSymbol ("mem_join_var_" ++ show blk ++ "_" ++ show (BV.asNatural off))) + (W4.BaseBVRepr bv_width) + let rgn = MemoryRegion + { regionOffset = off + , regionSize = sz + , regionStorage = storage_type + , regionJoinVar = join_var + } + return (Map.insert (BV.asNatural off) rgn off_map) + + | otherwise -> + C.panic + "SimpleLoopInvariant.simpleLoopInvariant" + ["unexpected storage type " ++ show storage_type ++ " of size " ++ show sz] + + + handleMemWrite mem_subst wr = + case wr of + C.MemWrite ptr (C.MemArrayStore _arr (Just len)) + | Just blk <- W4.asNat (C.llvmPointerBlock ptr) + , Just Refl <- testEquality (knownNat @64) (W4.bvWidth len) + -> case Map.lookup blk mem_subst of + Just (ArrayBlock _ _) -> return mem_subst + Just (RegularBlock _ _) -> + fail $ + "SimpleLoopInvariant: incompatible writes detected for block " ++ show blk + Nothing -> + do join_var <- liftIO $ + W4.freshConstant sym + (W4.safeSymbol ("smt_array_join_var_" ++ show blk)) + knownRepr + return (Map.insert blk (ArrayBlock join_var len) mem_subst) + + C.MemWrite ptr (C.MemStore _val storage_type _align) + | Just blk <- W4.asNat (C.llvmPointerBlock ptr) + , Just Refl <- testEquality (knownNat @64) (W4.bvWidth (C.llvmPointerOffset ptr)) + -> do (basePtr, off_map) <- + case Map.lookup blk mem_subst of + Just (ArrayBlock _ _) -> + fail $ + "SimpleLoopInvariant: incompatible writes detected for block " ++ + show blk + Just (RegularBlock basePtr off_map) -> return (basePtr, off_map) + Nothing -> return (C.llvmPointerOffset ptr, mempty) + + off_map' <- updateOffsetMap blk basePtr ptr storage_type off_map + return (Map.insert blk (RegularBlock basePtr off_map') mem_subst) + + w -> fail $ unlines $ + [ "SimpleLoopInvariant: unable to handle memory write of the form:" + , show (C.ppWrite w) + ] + +computeMemSubstitution :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + C.IsSymInterface sym => + sym -> + FixpointRecord p sym ext rtp blocks -> + C.MemWrites sym -> + FixpointMonad sym (MemorySubstitution sym) +computeMemSubstitution sym fixpoint_record mem_writes = + let ?ptrWidth = knownNat @64 in + do -- widen the memory + mem_subst_candidate <- liftIO $ constructMemSubstitutionCandidate sym mem_writes + + -- Check the candidate and raise errors if we cannot handle the resulting widening + res <- liftIO $ runExceptT $ + checkMemSubst sym (fixpointMemSubstitution fixpoint_record) + mem_subst_candidate + + case res of + Left msg -> fail $ unlines $ + [ "SimpleLoopInvariant: failure constructing memory footprint for loop invariant" + , msg + ] + Right x -> return x + + +-- | This function checks that the computed candidate memory substitution is an acceptable +-- refinement of the original. For the moment, this is a very restrictive test; either +-- we have started with an empty substitution (e.g., on the first iteration), or we have +-- computed a substitution that is exactly compatible with the one we started with. +-- +-- At some point, it may be necessary or desirable to allow more. +-- +-- Note:, for this check we do not need to compare the identities of the actual join variables +-- found in the substitution, just that the memory regions (positions and sizes) are equal. +checkMemSubst :: forall sym. + W4.IsSymExprBuilder sym => + sym -> + MemorySubstitution sym -> + MemorySubstitution sym -> + ExceptT String IO (MemorySubstitution sym) +checkMemSubst sym orig candidate = + if Map.null (memSubst orig) + then return candidate + else do checkCandidateEqual + return orig + + where + checkEqualMaps str f m1 m2 = + do unless (Map.keysSet m1 == Map.keysSet m2) + (throwError ("Key sets differ when checking " ++ str)) + forM_ (Map.assocs m1) $ \ (k,e1) -> + case Map.lookup k m2 of + Just e2 -> f k e1 e2 + Nothing -> throwError ("Key sets differ when checking " ++ str) + + checkCandidateEqual = + checkEqualMaps "memory substitution" checkMBD + (memSubst orig) (memSubst candidate) + + checkBVEq :: (1 <= w) => W4.SymBV sym w -> W4.SymBV sym w -> IO Bool + checkBVEq x y = + do diff <- W4.bvSub sym x y + case BV.asUnsigned <$> W4.asBV diff of + Just 0 -> return True + _ -> return False + + checkMBD n (RegularBlock b1 rmap1) (RegularBlock b2 rmap2) = + do ok <- liftIO $ checkBVEq b1 b2 + unless ok $ throwError $ + unlines ["base pointers differ for region " ++ show n + , show (W4.printSymExpr b1) + , show (W4.printSymExpr b2) + ] + checkEqualMaps ("region map for " ++ show n) (checkMemRegion n) rmap1 rmap2 + checkMBD n (ArrayBlock _a1 l1) (ArrayBlock _a2 l2) = + do ok <- liftIO $ checkBVEq l1 l2 + unless ok $ throwError $ + unlines [ "array lengths differ for region " ++ show n + , show (W4.printSymExpr l1) + , show (W4.printSymExpr l2) + ] + checkMBD n _ _ = + throwError ("Regular block incompatible with array block in region " ++ show n) + + checkMemRegion :: Natural -> Natural -> MemoryRegion sym -> MemoryRegion sym -> ExceptT String IO () + checkMemRegion n o r1 r2 = + do unless (regionOffset r1 == regionOffset r2) + (throwError ("region offsets differ in region " ++ show n ++ " at " ++ show o)) + unless (regionSize r1 == regionSize r2) + (throwError ("region sizes differ in region " ++ show n ++ " at " ++ show o)) + unless (regionStorage r1 == regionStorage r2) + (throwError ("region storage types differ in region " ++ show n ++ " at " ++ show o)) + +data MaybePausedFrameTgtId f where + JustPausedFrameTgtId :: C.Some (C.BlockID b) -> MaybePausedFrameTgtId (C.CrucibleLang b r) + NothingPausedFrameTgtId :: MaybePausedFrameTgtId f + +pausedFrameTgtId :: C.PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f +pausedFrameTgtId C.PausedFrame{ resume = resume } = case resume of + C.ContinueResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id + C.CheckMergeResumption (C.ResolvedJump tgt_id _) -> JustPausedFrameTgtId $ C.Some tgt_id + _ -> NothingPausedFrameTgtId diff --git a/src/Lang/Crucible/LLVM/SymIO.hs b/src/Lang/Crucible/LLVM/SymIO.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/SymIO.hs @@ -0,0 +1,619 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.SymIO +-- Description : Exporting SymbolicIO operations as Override templates +-- Copyright : (c) Galois, Inc 2020 +-- License : BSD3 +-- Maintainer : Daniel Matichuk +-- Stability : provisional +-- +-- +-- This module wraps the crucible-symio interface suitably for use within the +-- LLVM frontend to crucible. It provides overrides for the following functions: +-- +-- * @open@ +-- * @read@ +-- * @write@ +-- * @close@ +-- +-- as specified by POSIX. Note that it does not yet cover the C stdio functions. +-- This additional layer on top of crucible-symio is necessary to bridge the gap +-- between LLVMPointer arguments and more primitive argument types (including +-- that filenames need to be read from the LLVM memory model before they can be +-- interpreted). +-- +-- The limitations of this library are enumerated in the README for crux-llvm, +-- which is the user-facing documentation for this functionality. +------------------------------------------------------------------------ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Lang.Crucible.LLVM.SymIO + ( -- * Types + llvmSymIOIntrinsicTypes + , LLVMFileSystem(..) + , SomeOverrideSim(..) + , initialLLVMFileSystem + -- * Overrides + , symio_overrides + , openFile + , callOpenFile + , closeFile + , callCloseFile + , readFileHandle + , callReadFileHandle + , writeFileHandle + , callWriteFileHandle + -- * File-related utilities + , allocateFileDescriptor + , lookupFileHandle + ) + where + +import Control.Monad ( forM, foldM, when ) +import Control.Monad.IO.Class (liftIO) +import qualified Data.BitVector.Sized as BVS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Foldable as F +import qualified Data.Map as Map +import qualified Data.Parameterized.Classes as PC +import Data.Parameterized.Context + ( pattern (:>), pattern Empty, (::>), EmptyCtx, uncurryAssignment ) +import qualified Data.Parameterized.Map as MapF +import qualified Data.Parameterized.NatRepr as PN +import qualified Data.Parameterized.SymbolRepr as PS +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.Text.IO as Text.IO +import GHC.Natural ( Natural ) +import GHC.TypeNats ( type (<=) ) +import qualified System.IO as IO + +import qualified Lang.Crucible.FunctionHandle as LCF +import Lang.Crucible.Types ( IntrinsicType, BVType, TypeRepr(..) ) +import qualified Lang.Crucible.Utils.MuxTree as CMT +import Lang.Crucible.CFG.Common +import Lang.Crucible.Backend as C +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.Intrinsics +import Lang.Crucible.Simulator.RegMap +import qualified Lang.Crucible.Simulator.GlobalState as LCSG + +import Lang.Crucible.LLVM.Bytes (toBytes) +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.Extension ( ArchWidth ) +import Lang.Crucible.LLVM.DataLayout ( noAlignment ) +import Lang.Crucible.LLVM.Intrinsics +import Lang.Crucible.LLVM.QQ( llvmOvr ) + +import qualified What4.Interface as W4 +import qualified What4.Partial as W4P + +import qualified Lang.Crucible.SymIO as SymIO + +-- | A representation of the filesystem for the LLVM frontend +-- +-- This contains the underlying SymIO filesystem as well as the infrastructure +-- for allocating fresh file handles +data LLVMFileSystem ptrW = + LLVMFileSystem + { llvmFileSystem :: GlobalVar (SymIO.FileSystemType ptrW) + -- ^ The underlying symbolic filesystem + , llvmFileDescMap :: GlobalVar (FDescMapType ptrW) + -- ^ Maintains the mapping from file descriptors to low-level crucible-symio + -- 'SymIO.FileHandle's + , llvmHandles :: Map.Map Natural IO.Handle + -- ^ Handles that concrete output will be mirrored to; if this is empty, no + -- mirroring will be performed + , llvmFilePointerRepr :: PN.NatRepr ptrW + } + +-- | Contains the mapping from file descriptors to the underlying 'SymIO.FileHandle' +-- +-- This also tracks the next file descriptor to hand out. See Note [File +-- Descriptor Sequence]. +data FDescMap sym ptrW where + FDescMap :: + { fDescNext :: Natural + -- ^ The next file descriptor to hand out + -- + -- Note that these are truncated to 32 bit bitvectors when they are handed + -- out; we don't have any guards against overflow on that right now + , fDescMap :: Map.Map Natural (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW)) + } -> FDescMap sym ptrW + +-- | A wrapper around a RankN 'OverrideSim' action +-- +-- This enables us to make explicit that all of the type variables are free and +-- can be instantiated at any types since this override action has to be +-- returned from the 'initialLLVMFileSystem' function. +newtype SomeOverrideSim sym a where + SomeOverrideSim :: (forall p ext rtp args ret . OverrideSim p sym ext rtp args ret a) -> SomeOverrideSim sym a + +targetToFD :: SymIO.FDTarget k -> Maybe Natural +targetToFD t = + case t of + SymIO.StdinTarget -> Just 0 + SymIO.StdoutTarget -> Just 1 + SymIO.StderrTarget -> Just 2 + _ -> Nothing + +-- | Create an initial 'LLVMFileSystem' based on given concrete and symbolic file contents +-- +-- Note that this function takes a 'LCSG.SymGlobalState' because it needs to +-- allocate a few distinguished global variables for its own bookkeeping. It +-- adds them to the given global state and returns an updated global state, +-- which must not be discarded. +-- +-- The returned 'LLVMFileSystem' is a wrapper around that global state, and is +-- required to initialize the symbolic I/O overrides. +-- +-- This function also returns an 'OverrideSim' action (wrapped in a +-- 'SomeOverrideSim') that must be run to initialize any standard IO file +-- descriptors that have been requested. This action should be run *before* the +-- entry point of the function that is being verified is invoked. +-- +-- See Note [Standard IO Setup] for details +initialLLVMFileSystem + :: forall sym ptrW + . (HasPtrWidth ptrW, C.IsSymInterface sym) + => LCF.HandleAllocator + -> sym + -> PN.NatRepr ptrW + -- ^ The pointer width for the platform + -> SymIO.InitialFileSystemContents sym + -- ^ The initial contents of the symbolic filesystem + -> [(SymIO.FDTarget SymIO.Out, IO.Handle)] + -- ^ A mapping from file targets to handles, to which output should be + -- mirrored. This is intended to support mirroring symbolic stdout/stderr to + -- concrete stdout/stderr, but could be more flexible in the future (e.g., + -- handling sockets). + -- + -- Note that the writes to the associated underlying symbolic files are still + -- recorded in the symbolic filesystem + -> LCSG.SymGlobalState sym + -- ^ The current globals, which will be updated with necessary bindings to support the filesystem + -> IO (LLVMFileSystem ptrW, LCSG.SymGlobalState sym, SomeOverrideSim sym ()) +initialLLVMFileSystem halloc sym ptrW initContents handles globals0 = do + fs0 <- SymIO.initFS sym ptrW initContents + let fdm0 = FDescMap { fDescNext = 0 + , fDescMap = Map.empty + } + fsVar <- freshGlobalVar halloc (Text.pack "llvmFileSystem_Global") (SymIO.FileSystemRepr ptrW) + fdmVar <- freshGlobalVar halloc (Text.pack "llvmFileDescMap_Global") (FDescMapRepr ptrW) + let llfs = LLVMFileSystem { llvmFileSystem = fsVar + , llvmFileDescMap = fdmVar + , llvmFilePointerRepr = ptrW + , llvmHandles = Map.fromList [ (fd, hdl) + | (tgt, hdl) <- handles + , Just fd <- return (targetToFD tgt) + ] + } + let globals1 = LCSG.insertGlobal fdmVar fdm0 $ LCSG.insertGlobal fsVar fs0 globals0 + let bootstrapStdio :: OverrideSim p sym ext rtp args ret () + bootstrapStdio = do + -- Allocate the file handles for the standard IO streams in order such + -- that they are in file descriptors 0, 1, and 2 respectively + -- + -- We discard the actual file descriptors because they are accessed via + -- literals in the program. The 'allocateFileDescriptor' function + -- handles mapping the underlying FileHandle to an int file descriptor + -- internally. + let toLit = W4.Char8Literal . TextEncoding.encodeUtf8 . SymIO.fdTargetToText + when (Map.member SymIO.StdinTarget (SymIO.concreteFiles initContents) || Map.member SymIO.StdinTarget (SymIO.symbolicFiles initContents)) $ do + stdinFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StdinTarget) + _inFD <- SymIO.openFile' fsVar stdinFilename >>= allocateFileDescriptor llfs + return () + when (SymIO.useStdout initContents) $ do + stdoutFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StdoutTarget) + _outFD <- SymIO.openFile' fsVar stdoutFilename >>= allocateFileDescriptor llfs + return () + when (SymIO.useStderr initContents) $ do + stderrFilename <- liftIO $ W4.stringLit sym (toLit SymIO.StderrTarget) + _errFD <- SymIO.openFile' fsVar stderrFilename >>= allocateFileDescriptor llfs + return () + + return (llfs, globals1, SomeOverrideSim bootstrapStdio) + +type FDescMapType w = IntrinsicType "LLVM_fdescmap" (EmptyCtx ::> BVType w) + +instance (IsSymInterface sym) => IntrinsicClass sym "LLVM_fdescmap" where + type Intrinsic sym "LLVM_fdescmap" (EmptyCtx ::> BVType w) = FDescMap sym w + + muxIntrinsic sym _iTypes _nm (Empty :> (BVRepr _w)) = muxFDescMap sym + muxIntrinsic _ _ nm ctx = \_ _ _ -> typeError nm ctx + +pattern FDescMapRepr :: () => (1 <= w, ty ~ FDescMapType w) => PN.NatRepr w -> TypeRepr ty +pattern FDescMapRepr w <- IntrinsicRepr (PC.testEquality (PS.knownSymbol @"LLVM_fdescmap") -> Just PC.Refl) (Empty :> BVRepr w) + where + FDescMapRepr w = IntrinsicRepr PS.knownSymbol (Empty :> BVRepr w) + +muxFDescMap + :: IsSymInterface sym + => sym + -> W4.Pred sym + -> FDescMap sym ptrW + -> FDescMap sym ptrW + -> IO (FDescMap sym ptrW) +muxFDescMap sym p (FDescMap nextT mapT) (FDescMap nextF mapF) = do + let + keys = Set.toList $ Set.union (Map.keysSet mapT) (Map.keysSet mapF) + next = max nextT nextF + fmap (FDescMap next . Map.fromList) $ forM keys $ \k -> do + let vT = W4P.joinMaybePE (Map.lookup k mapT) + let vF = W4P.joinMaybePE (Map.lookup k mapF) + r <- mergePartExpr sym (CMT.mergeMuxTree sym) p vT vF + return (k,r) + +-- | The intrinsics supporting symbolic I/O in LLVM +-- +-- Note that this includes the base intrinsic types from crucible-symio, so +-- those do not need to be added again. +llvmSymIOIntrinsicTypes :: IsSymInterface sym => IntrinsicTypes sym +llvmSymIOIntrinsicTypes = id + . MapF.insert (PS.knownSymbol :: PS.SymbolRepr "LLVM_fdescmap") IntrinsicMuxFn + $ SymIO.symIOIntrinsicTypes + +-- | Resolve a symbolic file descriptor to a known allocated file handle. +-- The partial result is undefined if the descriptor is not found in the +-- file handle table. +getHandle + :: forall sym ptrW + . IsSymInterface sym + => sym + -> W4.SymBV sym 32 + -> FDescMap sym ptrW + -> IO (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW)) +getHandle sym fdesc (FDescMap _ m) = case W4.asBV fdesc of + Just fdesc_lit | Just fhdl <- Map.lookup (BVS.asNatural fdesc_lit) m -> return fhdl + _ -> do + cases <- mapM go (Map.assocs m) + foldM (\a (p, b) -> mergePartExpr sym (CMT.mergeMuxTree sym) p b a) W4P.Unassigned cases + where + go :: (Natural, (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW))) + -> IO (W4.Pred sym, (W4P.PartExpr (W4.Pred sym) (SymIO.FileHandle sym ptrW))) + go (n, fhdl) = do + n_sym <- W4.bvLit sym PN.knownNat (BVS.mkBV PN.knownNat (toInteger n)) + fdesc_eq <- W4.bvEq sym n_sym fdesc + return $ (fdesc_eq, fhdl) + +-- | Construct a 'SymIO.DataChunk' from a pointer +-- +-- Note that this is a lazy construct that does not load memory immediately. An +-- 'SymIO.DataChunk' is a wrapper around a function to peek memory at a given +-- offset one byte at a time. +chunkFromMemory + :: forall sym bak wptr + . (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) + => bak + -> MemImpl sym + -> LLVMPtr sym wptr + -> IO (SymIO.DataChunk sym wptr) +chunkFromMemory bak mem ptr = + let sym = backendGetSym bak in + SymIO.mkArrayChunk sym $ \offset -> do + ptr' <- ptrAdd sym PtrWidth ptr offset + llbytes <- doLoad bak mem ptr' (bitvectorType (toBytes (1 :: Integer))) (LLVMPointerRepr (PN.knownNat @8)) noAlignment + projectLLVM_bv bak llbytes + +-- | Retrieve the 'SymIO.FileHandle' that the given descriptor represents, +-- calling the continuation with 'Nothing' if the descriptor does not represent +-- a valid handle. Notably, a successfully resolved handle may itself still be closed. +-- +-- Note that the continuation may be called multiple times if it is used within +-- a symbolic branch. As a result, any side effects in the continuation may be +-- performed multiple times. +lookupFileHandle + :: IsSymInterface sym + => LLVMFileSystem wptr + -> W4.SymBV sym 32 + -> RegMap sym args'' + -> (forall args'. Maybe (SymIO.FileHandle sym wptr) -> RegMap sym args'' -> OverrideSim p sym ext r args' ret a) + -> OverrideSim p sym ext r args ret a +lookupFileHandle fsVars fdesc args cont = do + descMap <- readGlobal (llvmFileDescMap fsVars) + sym <- getSymInterface + (liftIO $ getHandle sym fdesc descMap) >>= \case + W4P.PE p fhdl -> do + symbolicBranch p + args (getOverrideArgs >>= \args' -> cont (Just fhdl) args') Nothing + args (getOverrideArgs >>= \args' -> cont Nothing args') Nothing + W4P.Unassigned -> cont Nothing args + + +-- | Allocate a fresh (integer/bitvector(32)) file descriptor that is associated with the given 'SymIO.FileHandle' +-- +-- NOTE that this is a file descriptor in the POSIX sense, rather than a @FILE*@ +-- or the underlying 'SymIO.FileHandle'. +-- +-- NOTE that we truncate the file descriptor source to 32 bits in this function; +-- it could in theory overflow. +-- +-- NOTE that the file descriptor counter is incremented monotonically as the +-- simulator hits calls to @open@; this means that calls to @open@ in parallel +-- control flow branches would get sequential file descriptor values whereas the +-- real program would likely allocate the same file descriptor value on both +-- branches. This could be relevant for some bug finding scenarios. +-- +-- TODO It would be interesting if we could add a symbolic offset to these +-- values so that we can't make any concrete assertions about them. It isn't +-- clear if that ever happens in real code. If we do that, we need an escape +-- hatch to let us allocate file descriptors 0, 1, and 2 if needed. +allocateFileDescriptor + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMFileSystem wptr + -> SymIO.FileHandle sym wptr + -> OverrideSim p sym ext r args ret (W4.SymBV sym 32) +allocateFileDescriptor fsVars fh = do + sym <- getSymInterface + modifyGlobal (llvmFileDescMap fsVars) $ \(FDescMap next descMap) -> do + fdesc <- liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) (toInteger next)) + let ptrMap' = Map.insert next (W4P.justPartExpr sym fh) descMap + return (fdesc, FDescMap (next + 1) ptrMap') + +loadFileIdent + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) + => GlobalVar Mem + -> LLVMPtr sym wptr + -> OverrideSim p sym ext r args ret (SymIO.FileIdent sym) +loadFileIdent memOps filename_ptr = + ovrWithBackend $ \bak -> + do mem <- readGlobal memOps + filename_bytes <- liftIO $ loadString bak mem filename_ptr Nothing + liftIO $ W4.stringLit (backendGetSym bak) (W4.Char8Literal (BS.pack filename_bytes)) + +returnIOError32 + :: IsSymInterface sym + => OverrideSim p sym ext r args ret (W4.SymBV sym 32) +returnIOError32 = do + sym <- getSymInterface + liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) (-1)) + +returnIOError + :: forall wptr p sym ext r args ret + . (IsSymInterface sym, HasPtrWidth wptr) + => OverrideSim p sym ext r args ret (W4.SymBV sym wptr) +returnIOError = do + sym <- getSymInterface + liftIO $ W4.bvLit sym PtrWidth (BVS.mkBV PtrWidth (-1)) + +openFile + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) + => LLVMFileSystem wptr + -> LLVMOverride p sym + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 32) + (BVType 32) +openFile fsVars = + [llvmOvr| i32 @open( i8*, i32 ) |] + -- TODO add mode support by making this a varargs function + (\memOps bak args -> uncurryAssignment (callOpenFile bak memOps fsVars) args) + +callOpenFile :: + (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => + bak -> + GlobalVar Mem -> + LLVMFileSystem wptr -> + RegEntry sym (LLVMPointerType wptr) -> + RegEntry sym (BVType 32) -> + OverrideSim p sym ext rtp args ret (RegValue sym (BVType 32)) +callOpenFile _bak memOps fsVars filename_ptr _flags = + do fileIdent <- loadFileIdent memOps (regValue filename_ptr) + SymIO.openFile (llvmFileSystem fsVars) fileIdent $ \case + Left SymIO.FileNotFound -> returnIOError32 + Right fileHandle -> allocateFileDescriptor fsVars fileHandle + +closeFile + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMFileSystem wptr + -> LLVMOverride p sym + (EmptyCtx ::> BVType 32) + (BVType 32) +closeFile fsVars = + [llvmOvr| i32 @close( i32 ) |] + (\memOps bak args -> uncurryAssignment (callCloseFile bak memOps fsVars) args) + +callCloseFile :: + (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) => + bak -> + GlobalVar Mem -> + LLVMFileSystem wptr -> + RegEntry sym (BVType 32) -> + OverrideSim p sym ext rtp args ret (RegValue sym (BVType 32)) +callCloseFile bak _memOps fsVars filedesc = + do let sym = backendGetSym bak + lookupFileHandle fsVars (regValue filedesc) emptyRegMap $ \case + Just fileHandle -> \_ -> + SymIO.closeFileHandle (llvmFileSystem fsVars) fileHandle $ \case + Just SymIO.FileHandleClosed -> returnIOError32 + Nothing -> liftIO $ W4.bvLit sym (PN.knownNat @32) (BVS.mkBV (PN.knownNat @32) 0) + Nothing -> \_ -> returnIOError32 + +readFileHandle + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMFileSystem wptr + -> LLVMOverride p sym + (EmptyCtx ::> BVType 32 + ::> LLVMPointerType wptr + ::> BVType wptr) + (BVType wptr) +readFileHandle fsVars = + [llvmOvr| ssize_t @read( i32, i8*, size_t ) |] + (\memOps bak args -> uncurryAssignment (callReadFileHandle bak memOps fsVars) args) + +callReadFileHandle :: + (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) => + bak -> + GlobalVar Mem -> + LLVMFileSystem wptr -> + RegEntry sym (BVType 32) -> + RegEntry sym (LLVMPointerType wptr) -> + RegEntry sym (BVType wptr) -> + OverrideSim p sym ext rtp args ret (RegValue sym (BVType wptr)) +callReadFileHandle bak memOps fsVars filedesc buf count = + do let sym = backendGetSym bak + let args = Empty :> filedesc :> buf :> count + lookupFileHandle fsVars (regValue filedesc) (RegMap args) $ \case + Just fileHandle -> \(RegMap (Empty :> _ :> buffer_ptr :> size)) -> + SymIO.readChunk (llvmFileSystem fsVars) fileHandle (regValue size) $ \case + Left SymIO.FileHandleClosed -> returnIOError + Right (chunk, bytesRead) -> do + modifyGlobal memOps $ \mem -> liftIO $ do + chunkArray <- SymIO.chunkToArray sym (W4.BaseBVRepr PtrWidth) chunk + mem' <- doArrayStore bak mem (regValue buffer_ptr) noAlignment chunkArray bytesRead + return (bytesRead, mem') + Nothing -> \_ -> returnIOError + +-- | If the write is to a concrete FD for which we have an associated 'IO.Handle', mirror the write to that Handle +-- +-- This is intended to support mirroring stdout/stderr in a user-visible way +-- (noting that symbolic IO can be repeated due to the simulator branching). +-- Note also that only writes of a concrete length are mirrored reasonably; +-- writes with symbolic length are denoted with a substitute token. Likewise +-- individual symbolic bytes are printed as @?@ characters. +doConcreteWrite + :: (IsSymInterface sym, HasPtrWidth wptr) + => PN.NatRepr wptr + -> Map.Map Natural IO.Handle + -> RegValue sym (BVType 32) + -> SymIO.DataChunk sym wptr + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext rtp args ret () +doConcreteWrite ptrw handles symFD chunk size = + case W4.asBV symFD of + Just (BVS.asNatural -> fd) + | Just hdl <- Map.lookup fd handles + , Just numBytes <- BVS.asUnsigned <$> W4.asBV (regValue size) -> do + -- We have a concrete size of the write and an IO Handle to write + -- to. Write each byte that is concrete, or replace it with a '?' + sym <- getSymInterface + F.forM_ [0..numBytes - 1] $ \idx -> do + idxBV <- liftIO $ W4.bvLit sym ptrw (BVS.mkBV ptrw idx) + byteVal <- liftIO $ SymIO.evalChunk chunk idxBV + case W4.asBV byteVal of + Just (BVS.asUnsigned -> concByte) -> liftIO $ BS.hPut hdl (BS.pack [fromIntegral concByte]) + Nothing -> liftIO $ BS.hPut hdl (BSC.pack ['?']) + | Just hdl <- Map.lookup fd handles -> do + -- In this case, we have a write of symbolic size. We can't really + -- write that out, but do our best + liftIO $ Text.IO.hPutStr hdl (Text.pack "[‽]") + _ -> return () + +writeFileHandle + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) + => LLVMFileSystem wptr + -> LLVMOverride p sym + (EmptyCtx ::> BVType 32 + ::> LLVMPointerType wptr + ::> BVType wptr) + (BVType wptr) +writeFileHandle fsVars = + [llvmOvr| ssize_t @write( i32, i8*, size_t ) |] + (\memOps bak args -> uncurryAssignment (callWriteFileHandle bak memOps fsVars) args) + +callWriteFileHandle :: + (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => + bak -> + GlobalVar Mem -> + LLVMFileSystem wptr -> + RegEntry sym (BVType 32) -> + RegEntry sym (LLVMPointerType wptr) -> + RegEntry sym (BVType wptr) -> + OverrideSim p sym ext rtp args ret (RegValue sym (BVType wptr)) +callWriteFileHandle bak memOps fsVars filedesc buf count = + do let args = Empty :> filedesc :> buf :> count + lookupFileHandle fsVars (regValue filedesc) (RegMap args) $ \case + Just fileHandle -> \(RegMap (Empty :> _ :> buffer_ptr :> size)) -> do + mem <- readGlobal memOps + chunk <- liftIO $ chunkFromMemory bak mem (regValue buffer_ptr) + doConcreteWrite (llvmFilePointerRepr fsVars) (llvmHandles fsVars) (regValue filedesc) chunk size + SymIO.writeChunk (llvmFileSystem fsVars) fileHandle chunk (regValue size) $ \case + Left SymIO.FileHandleClosed -> returnIOError + Right bytesWritten -> return bytesWritten + Nothing -> \_ -> returnIOError + +-- | The file handling overrides +-- +-- See the 'initialLLVMFileSystem' function for creating the initial filesystem state +symio_overrides + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?memOpts :: MemOptions) + => LLVMFileSystem wptr + -> [OverrideTemplate p sym arch rtp l a] +symio_overrides fs = + [ basic_llvm_override $ openFile fs + , basic_llvm_override $ closeFile fs + , basic_llvm_override $ readFileHandle fs + , basic_llvm_override $ writeFileHandle fs + ] + +{- Note [Standard IO Setup] + +The underlying symbolic IO library hands out abstract 'FileHande's, which are an +internal type that do not correspond to any source-level data values. Frontends +must map them to something from the target programming language. In this +module, that means we must map them to POSIX file descriptors (represented as C +ints). + +In particular, when setting up the symbolic execution engine, we want to be able +to map standard input, standard output, and standard error to their prescribed +file descriptors (0, 1, and 2 respectively). We can do that by simply +allocating them in order, as we start the file descriptor counter at 0 (see +'FDescMap'). Note that we just reuse the existing infrastructure to allocate +file descriptors (in particular, 'allocateFileDescriptor'). Note that we do +*not* use the 'openFile' function defined in this module because it expects the +filename to be stored in the LLVM memory, which our magic names for the standard +streams are not. + +Note that if we start the symbolic execution engine without standard +in/out/error, we could potentially hand out file descriptors at these usually +reserved numbers. That isn't necessarily a problem, but it could be. We could +one day provide a method for forcing file descriptors to start at 3 even if +these special files are not allocated (i.e., start off closed). We should +investigate the behavior of the OS and mimic it (or make it an option). + +As a note on file names, the standard IO streams do not have prescribed names +that can be opened. We use synthetic names defined in the underlying +architecture-independent symbolic IO library. We do not need to know what they +are here, but they are arranged to not collide with any valid names for actual +files in the symbolic filesystem. + +-} + +{- Note [File Descriptor Sequence] + +This code uses a global counter to provide the next file descriptor to hand out +when a file is opened. This can lead to a subtle difference in behavior +compared to a real program. + +Consider the case where a program contains a symbolic branch where both branches +open files. The symbolic I/O system will allocate each of the opened files a +different file descriptor. In contrast, a real system would only assign one of +those file descriptors because it would only see one branch. This means that +later opened files would differ from the real program. + +This should only be observable if the program makes control decisions based on +the values in file descriptors, which it really should not. However, it is +possible in the real world. + +-} diff --git a/src/Lang/Crucible/LLVM/Translation.hs b/src/Lang/Crucible/LLVM/Translation.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation.hs @@ -0,0 +1,544 @@ +-- | +-- Module : Lang.Crucible.LLVM.Translation +-- Description : Translation of LLVM AST into Crucible control-flow graph +-- Copyright : (c) Galois, Inc 2014-2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module translates an LLVM 'Module' into a collection of Crucible +-- control-flow graphs, one per function. The tricky parts of this translation +-- are 1) mapping LLVM types onto Crucible types in a sensible way and 2) +-- translating the phi-instructions of LLVM's SSA form. +-- +-- To handle the translation of phi-functions, we first perform a +-- pre-pass over all the LLVM basic blocks looking for phi-functions +-- and build a datastructure that tells us what assignments to make +-- when jumping from block l to block l'. We then emit instructions +-- to make these assignments in a separate Crucible basic block (see +-- 'definePhiBlock'). Thus, the translated CFG will generally have +-- more basic blocks than the original LLVM. +-- +-- Points of note: +-- +-- * Immediate (i.e., not in memory) structs and packed structs are translated the same. +-- * Undefined values generate special Crucible expressions (e.g., BVUndef) to +-- represent arbitrary bitpatterns. +-- * The floating-point domain is interpreted by IsSymInterface as either +-- the IEEE754 floating-point domain, the real domain, or a domain with +-- bitvector values and uninterpreted operations. +-- +-- Some notes on undefined/poison values: (outcome of discussions between JHx and RWD) +-- +-- * Continue to add Crucible expressions for undefined values as +-- required (e.g. for floating-point values). Crucible itself is +-- currently treating undefined values as fresh symbolic inputs; it +-- should instead invent a new category of "arbitrary" values that get +-- passed down into the solvers in a way that is dependent on the task +-- at hand. For example, in verification tasks, it is appropriate to +-- treat the arbitrary values the same as symbolic inputs. However, +-- for preimage-finding tasks, the arbitrary values must be treated as +-- universally-quantified, unlike the symbolic inputs which are +-- existentially-quantified. +-- +-- * For poison values, our implementation strategy is to assert +-- side conditions onto values that may create poison. As opposed +-- to assertions (which must be satisfied because you passed through +-- a control-flow point) side conditions are intended to mean that +-- a condition must hold when a value is used (i.e., side conditions +-- follow data-flow). So if a poison value is created but not examined +-- (e.g., because we later do a test to determine if the value is safe), +-- that should be allowed. +-- +-- A (probably) partial list of things we intend to support, but do not yet: +-- +-- * Various vector instructions. This includes a variety of instructions +-- that LLVM allows to take vector arguments, but are currently only +-- defined on scalar (nonvector) arguments. (Progress has been made on +-- this, but may not yet be complete). +-- +-- A list of things that are unsupported and may never be: +-- +-- * Computed jumps and blockaddress expressions +-- * Multithreading primitives +-- * Alternate calling conventions +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Translation + ( ModuleTranslation + , getTranslatedCFG + , getTranslatedFnHandle + , transContext + , globalInitMap + , modTransDefs + , modTransModule + , modTransHalloc + , LLVMContext(..) + , llvmTypeCtx + , translateModule + , LLVMTranslationWarning(..) + + , module Lang.Crucible.LLVM.Translation.Constant + , module Lang.Crucible.LLVM.Translation.Options + , module Lang.Crucible.LLVM.Translation.Types + ) where + +import Control.Lens hiding (op, (:>) ) +import Control.Monad (foldM) +import Data.IORef (IORef, newIORef, readIORef, modifyIORef) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe +import Data.String +import qualified Data.Text as Text +import Prettyprinter (pretty) + +import qualified Text.LLVM.AST as L + +import Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Some +import Data.Parameterized.Nonce + +import What4.FunctionName +import What4.ProgramLoc + +import qualified Lang.Crucible.CFG.Core as C +import Lang.Crucible.CFG.Generator +import Lang.Crucible.CFG.SSAConversion( toSSA ) + +import Lang.Crucible.FunctionHandle +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.Globals +import Lang.Crucible.LLVM.MemModel +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.Translation.Aliases +import Lang.Crucible.LLVM.Translation.Constant +import Lang.Crucible.LLVM.Translation.Expr +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Options +import Lang.Crucible.LLVM.Translation.Instruction +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.Types + + +------------------------------------------------------------------------ +-- Translation results + +type ModuleCFGMap = Map L.Symbol CFGMapEntry + +data CFGMapEntry + = TranslatedCFG L.Declare (C.AnyCFG LLVM) + | UntranslatedCFG L.Define SomeHandle + +-- | The result of translating an LLVM module into Crucible CFGs. +data ModuleTranslation arch + = ModuleTranslation + { _cfgMap :: IORef ModuleCFGMap + , _transContext :: LLVMContext arch + , _globalInitMap :: GlobalInitializerMap + -- ^ A map from global names to their (constant) values + -- Note: Willy-nilly global initialization may be unsound in the + -- presence of compositional verification. + , _modTransNonce :: !(Nonce GlobalNonceGenerator arch) + -- ^ For a reasonably quick 'testEquality' instance + , _modTransDefs :: ![(L.Declare, SomeHandle)] + -- ^ A collection of declarations for all the functions + -- defined in this module. + , _modTransHalloc :: HandleAllocator + , _modTransModule :: L.Module + , _modTransOpts :: TranslationOptions + } + +instance TestEquality ModuleTranslation where + testEquality mt1 mt2 = + testEquality (_modTransNonce mt1) (_modTransNonce mt2) + +transContext :: Getter (ModuleTranslation arch) (LLVMContext arch) +transContext = to _transContext + +globalInitMap :: Getter (ModuleTranslation arch) GlobalInitializerMap +globalInitMap = to _globalInitMap + +modTransDefs :: Getter (ModuleTranslation arch) [(L.Declare,SomeHandle)] +modTransDefs = to _modTransDefs + +modTransModule :: Getter (ModuleTranslation arch) L.Module +modTransModule = to _modTransModule + +modTransHalloc :: Getter (ModuleTranslation arch) HandleAllocator +modTransHalloc = to _modTransHalloc + +typeToRegExpr :: MemType -> LLVMGenerator s arch ret (Some (Reg s)) +typeToRegExpr tp = do + llvmTypeAsRepr tp $ \tpr -> + Some <$> newUnassignedReg tpr + +-- | This function pre-computes the types of all the crucible registers by scanning +-- through each basic block and finding the place where that register is assigned. +-- Because LLVM programs are in SSA form, this will occur in exactly one place. +-- The type of the register is inferred from the instruction that assigns to it +-- and is recorded in the ident map. +buildRegMap :: IdentMap s -> L.Define -> LLVMGenerator s arch reg (IdentMap s) +buildRegMap m d = foldM (\m0 bb -> buildRegTypeMap m0 bb) m $ L.defBody d + +buildRegTypeMap :: IdentMap s + -> L.BasicBlock + -> LLVMGenerator s arch ret (IdentMap s) +buildRegTypeMap m0 bb = foldM stmt m0 (L.bbStmts bb) + where + err instr msg = + malformedLLVMModule "Invalid type in instruction result" + [ fromString (showInstr instr) + , fromString msg + ] + + stmt m (L.Effect _ _) = return m + stmt m (L.Result ident instr _) = do + ty <- either (err instr) return $ instrResultType instr + ex <- typeToRegExpr ty + case Map.lookup ident m of + Just _ -> + malformedLLVMModule "Register not used in SSA fashion" + [ fromString (show ident) + , fromString (showInstr instr) + ] + Nothing -> return $ Map.insert ident (Left ex) m + + +-- | Generate crucible code for each LLVM statement in turn. +generateStmts :: (?transOpts :: TranslationOptions) + => TypeRepr ret + -> L.BlockLabel + -> Set L.Ident {- ^ Set of usable identifiers -} + -> [L.Stmt] + -> LLVMGenerator s arch ret a +generateStmts retType lab defSet0 stmts = go defSet0 (processDbgDeclare stmts) + where go _ [] = fail "LLVM basic block ended without a terminating instruction" + go defSet (x:xs) = + case x of + -- a result statement assigns the result of the instruction into a register + L.Result ident instr md -> + do setLocation md + generateInstr retType lab defSet instr + (assignLLVMReg ident) + (go (Set.insert ident defSet) xs) + + -- an effect statement simply executes the instruction for its effects and discards the result + L.Effect instr md -> + do setLocation md + generateInstr retType lab defSet instr + (\_ -> return ()) + (go defSet xs) + +-- | Search for calls to intrinsic 'llvm.dbg.declare' and copy the +-- metadata onto the corresponding 'alloca' statement. Also copy +-- metadata backwards from 'bitcast' statements toward 'alloca'. +processDbgDeclare :: [L.Stmt] -> [L.Stmt] +processDbgDeclare = snd . go + where + go :: [L.Stmt] -> (Map L.Ident [(String, L.ValMd)] , [L.Stmt]) + go [] = (Map.empty, []) + go (stmt : stmts) = + let (m, stmts') = go stmts in + case stmt of + L.Result x instr@L.Alloca{} md -> + case Map.lookup x m of + Just md' -> (m, L.Result x instr (md' ++ md) : stmts') + Nothing -> (m, stmt : stmts') + --error $ "Identifier not found: " ++ show x ++ "\nPossible identifiers: " ++ show (Map.keys m) + + L.Result x (L.Conv L.BitCast (L.Typed _ (L.ValIdent y)) _) md -> + let md' = md ++ fromMaybe [] (Map.lookup x m) + m' = Map.alter (Just . maybe md' (md'++)) y m + in (m', stmt:stmts) + + L.Effect (L.Call _ _ (L.ValSymbol "llvm.dbg.declare") (L.Typed _ (L.ValMd (L.ValMdValue (L.Typed _ (L.ValIdent x)))) : _)) md -> + (Map.insert x md m, stmt : stmts') + + -- This is needlessly fragile. Let's just ignore debug declarations we don't understand. + -- L.Effect (L.Call _ _ (L.ValSymbol "llvm.dbg.declare") args) md -> + -- error $ "Ill-formed arguments to llvm.dbg.declare: " ++ show (args, md) + + _ -> (m, stmt : stmts') + +setLocation + :: [(String,L.ValMd)] + -> LLVMGenerator s arch ret () +setLocation [] = return () +setLocation (x:xs) = + case x of + ("dbg",L.ValMdLoc dl) -> + let ln = fromIntegral $ L.dlLine dl + col = fromIntegral $ L.dlCol dl + file = getFile $ L.dlScope dl + in setPosition (SourcePos file ln col) + ("dbg",L.ValMdDebugInfo (L.DebugInfoSubprogram subp)) + | Just file' <- L.dispFile subp + -> let ln = fromIntegral $ L.dispLine subp + file = getFile file' + in setPosition (SourcePos file ln 0) + _ -> setLocation xs + + where + getFile = Text.pack . maybe "" filenm . findFile + + -- The typical values available here will be something like: + -- + -- > L.difDirectory = "/home/joeuser/work" + -- > L.difFilename = "src/lib/foo.c" + -- + -- At the present time, only the 'difFilename' is used for the + -- relative path because combining these to form an absolute path + -- would cause superfluous result differences (e.g. golden test + -- failures) and potentially leak information. + -- + -- The downside is that relative paths may make it harder for various + -- tools (e.g. emacs) to locate the offending source file. The + -- suggested method for handling this is to have the emacs compile + -- function emit an initial rooted directory location in the proper + -- syntax, but if this is problematic, a future direction would be to + -- add a config option to control whether an absolute or a relative + -- path is desired (defaulting to the latter). + -- + -- [The previous implementation always generated absolute paths, but + -- was careful to check if `difFilename` was already absolute.] + filenm = L.difFilename + +findFile :: (?lc :: TypeContext) => L.ValMd -> Maybe L.DIFile +findFile (L.ValMdRef x) = findFile =<< lookupMetadata x + +findFile (L.ValMdNode (_:Just (L.ValMdRef y):_)) = + case lookupMetadata y of + Just (L.ValMdNode [Just (L.ValMdString fname), Just (L.ValMdString fpath)]) -> + Just (L.DIFile fname fpath) + _ -> Nothing + +findFile (L.ValMdDebugInfo di) = + case di of + L.DebugInfoFile dif -> Just dif + L.DebugInfoLexicalBlock dilex + | Just md <- L.dilbFile dilex -> findFile md + | Just md <- L.dilbScope dilex -> findFile md + L.DebugInfoLexicalBlockFile dilexFile + | Just md <- L.dilbfFile dilexFile -> findFile md + | otherwise -> findFile (L.dilbfScope dilexFile) + L.DebugInfoSubprogram disub + | Just md <- L.dispFile disub -> findFile md + | Just md <- L.dispScope disub -> findFile md + _ -> Nothing + +findFile _ = Nothing + +-- | Lookup the block info for the given LLVM block and then define a new crucible block +-- by translating the given LLVM statements. +defineLLVMBlock + :: (?transOpts :: TranslationOptions) + => TypeRepr ret + -> LLVMBlockInfoMap s + -> L.BasicBlock + -> LLVMGenerator s arch ret () +defineLLVMBlock retType lm L.BasicBlock{ L.bbLabel = Just lab, L.bbStmts = stmts } = do + case Map.lookup lab lm of + Just bi -> defineBlock (block_label bi) (generateStmts retType lab (block_use_set bi) stmts) + Nothing -> fail $ unwords ["LLVM basic block not found in block info map", show lab] + +defineLLVMBlock _ _ _ = fail "LLVM basic block has no label!" + +-- | Do some initial preprocessing to find all the phi nodes in the program +-- and to preallocate all the crucible registers we will need based on the LLVM +-- types of all the LLVM registers. Then translate each LLVM basic block in turn. +-- +-- This step introduces a new dummy entry point that simply jumps to the LLVM entry +-- point. It is inconvenient to avoid doing this when using the Generator interface. +genDefn :: (?transOpts :: TranslationOptions) + => L.Define + -> TypeRepr ret + -> LLVMGenerator s arch ret (Expr ext s ret) +genDefn defn retType = + case L.defBody defn of + [] -> fail "LLVM define with no blocks!" + ( L.BasicBlock{ L.bbLabel = Nothing } : _ ) -> fail $ unwords ["entry block has no label"] + ( L.BasicBlock{ L.bbLabel = Just entry_lab } : _ ) -> do + let (L.Symbol nm) = L.defName defn + callPushFrame $ Text.pack nm + setLocation $ Map.toList (L.defMetadata defn) + + bim <- buildBlockInfoMap defn + blockInfoMap .= bim + + im <- use identMap + im' <- buildRegMap im defn + identMap .= im' + + case Map.lookup entry_lab bim of + Nothing -> fail $ unwords ["entry label not found in label map:", show entry_lab] + Just entry_bi -> do + checkEntryPointUseSet nm entry_bi (L.defArgs defn) + mapM_ (\bb -> defineLLVMBlock retType bim bb) (L.defBody defn) + jump (block_label entry_bi) + + +-- | Check that the input LLVM CFG satisfies the def/use invariant, +-- and raise an error if some virtual register has a use site that +-- is not dominated by its definition site. +checkEntryPointUseSet :: + String -> + LLVMBlockInfo s -> + [L.Typed L.Ident] -> + LLVMGenerator s arg ret () +checkEntryPointUseSet nm bi args + | Set.null unsatisfiedUses = return () + | otherwise = + malformedLLVMModule ("Invalid SSA form for function: " <> pretty nm) + ([ "The following LLVM virtual registers have at least one use site that" + , "is not dominated by the corresponding definition:" ] ++ + [ " " <> pretty (show (LPP.ppIdent i)) | i <- Set.toList unsatisfiedUses ]) + where + argSet = Set.fromList (map L.typedValue args) + useSet = block_use_set bi + unsatisfiedUses = Set.difference useSet argSet + +------------------------------------------------------------------------ +-- transDefine +-- +-- | Translate a single LLVM function definition into a crucible CFG. +-- +transDefine :: forall arch wptr args ret. + (HasPtrWidth wptr, wptr ~ ArchWidth arch, ?transOpts :: TranslationOptions) => + FnHandle args ret -> + LLVMContext arch -> + IORef [LLVMTranslationWarning] -> + L.Define -> + IO (L.Declare, C.AnyCFG LLVM) +transDefine h ctx warnRef d = do + let ?lc = ctx^.llvmTypeCtx + let decl = declareFromDefine d + let L.Symbol fstr = L.defName d + + llvmDeclToFunHandleRepr' decl $ \argTys retTy -> + case (testEquality argTys (handleArgTypes h), + testEquality retTy (handleReturnType h)) of + (Nothing, _) -> fail $ unlines + [ "Argument type mismatch when defining function: " ++ fstr + , show argTys + , show h ] + (_, Nothing) -> fail $ unlines $ + [ "Return type mismatch when bootstrapping function: " ++ fstr + , show retTy, show h + ] + (Just Refl, Just Refl) -> + do let def :: FunctionDef LLVM (LLVMState arch) args ret IO + def inputs = (s, f) + where s = initialState d ctx argTys inputs warnRef + f = genDefn d retTy + sng <- newIONonceGenerator + (SomeCFG g, []) <- defineFunctionOpt InternalPos sng h def $ \ng cfg -> + if optLoopMerge ?transOpts then earlyMergeLoops ng cfg else return cfg + case toSSA g of + C.SomeCFG g_ssa -> g_ssa `seq` return (decl, C.AnyCFG g_ssa) + + +------------------------------------------------------------------------ +-- translateModule + +-- | Translate a module into Crucible control-flow graphs. +-- Return the translated module and a list of warning messages +-- generated during translation. +-- Note: We may want to add a map from symbols to existing function handles +-- if we want to support dynamic loading. +translateModule :: (?transOpts :: TranslationOptions) + => HandleAllocator -- ^ Generator for nonces. + -> GlobalVar Mem -- ^ Memory model to associate with this context + -> L.Module -- ^ Module to translate + -> IO (Some ModuleTranslation) +translateModule halloc mvar m = do + Some ctx <- mkLLVMContext mvar m + let nonceGen = haCounter halloc + llvmPtrWidth ctx $ \wptr -> withPtrWidth wptr $ + do let ?lc = ctx^.llvmTypeCtx -- implicitly passed to makeGlobalMap + let ctx' = ctx{ llvmGlobalAliases = globalAliases m + , llvmFunctionAliases = functionAliases m + } + nonce <- freshNonce nonceGen + prep <- mapM (prepareCFGMapEntry halloc) (L.modDefines m) + cfgRef <- newIORef $! Map.fromList [ (L.defName def, UntranslatedCFG def h) | (def,_,h) <- prep ] + return (Some (ModuleTranslation { _cfgMap = cfgRef + , _globalInitMap = makeGlobalMap ctx' m + , _transContext = ctx' + , _modTransNonce = nonce + , _modTransDefs = [ (decl,h) | (_,decl,h) <- prep ] + , _modTransHalloc = halloc + , _modTransModule = m + , _modTransOpts = ?transOpts + })) + +prepareCFGMapEntry :: + (HasPtrWidth wptr, ?lc :: TypeContext) => + HandleAllocator -> + L.Define -> + IO (L.Define, L.Declare, SomeHandle) +prepareCFGMapEntry halloc def = + let decl = declareFromDefine def in + let L.Symbol fstr = L.defName def in + let fn_name = functionNameFromText $ Text.pack fstr in + llvmDeclToFunHandleRepr' decl $ \argTys retTy -> + do h <- mkHandle' halloc fn_name argTys retTy + return (def, decl, SomeHandle h) + + +-- | Given a 'ModuleTranslation' and a function symbol corresponding to a function +-- defined in the module, attempt to look up the symbol name and retrieve the corresponding +-- Crucible CFG. This will load and translate the CFG if this is the first time +-- the given symbol is requested. +-- +-- Will return 'Nothing' if the symbol does not refer to a function defined in this +-- module. +getTranslatedCFG :: + ModuleTranslation arch -> + L.Symbol -> + IO (Maybe (L.Declare, C.AnyCFG LLVM, [LLVMTranslationWarning])) +getTranslatedCFG mt s = + do m <- readIORef (_cfgMap mt) + case Map.lookup s m of + Nothing -> return Nothing + Just (TranslatedCFG decl cfg) -> return (Just (decl, cfg, [])) + Just (UntranslatedCFG def (SomeHandle h)) -> + let ?transOpts = _modTransOpts mt in + let ctx = _transContext mt in + llvmPtrWidth ctx $ \wptr -> withPtrWidth wptr $ + do warnRef <- newIORef [] + (decl, cfg) <- transDefine h ctx warnRef def + warns <- reverse <$> readIORef warnRef + modifyIORef (_cfgMap mt) (Map.insert s (TranslatedCFG decl cfg)) + return (Just (decl, cfg, warns)) + +-- | Look up the signature and function handle for a function defined in this +-- module translation. This does not trigger translation of the named function +-- into Crucible if it has not already been requested. +-- +-- Will return 'Nothing' if the symbol does not refer to a function defined in this +-- module. +getTranslatedFnHandle :: + ModuleTranslation arch -> + L.Symbol -> + IO (Maybe (L.Declare, SomeHandle)) +getTranslatedFnHandle mt s = + do m <- readIORef (_cfgMap mt) + case Map.lookup s m of + Nothing -> return Nothing + Just (TranslatedCFG decl (C.AnyCFG cfg)) -> return (Just (decl, SomeHandle (C.cfgHandle cfg))) + Just (UntranslatedCFG def h) -> return (Just (declareFromDefine def, h)) diff --git a/src/Lang/Crucible/LLVM/Translation/Aliases.hs b/src/Lang/Crucible/LLVM/Translation/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Aliases.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Aliases +-- Description : Resolution of global and function aliases +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +----------------------------------------------------------------------- +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TypeFamilies #-} + +module Lang.Crucible.LLVM.Translation.Aliases + ( globalAliases + , functionAliases + , reverseAliases + ) where + +import Control.Monad +import Control.Monad.Trans.State + +import qualified Data.List as List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +import qualified Text.LLVM.AST as L + +import Lang.Crucible.Panic (panic) +import Lang.Crucible.LLVM.Types +import Lang.Crucible.LLVM.TypeContext (TypeContext) +import Lang.Crucible.LLVM.Translation.Constant + +-- | Reverse a set of alias/aliasee relationships +-- +-- Given a list of values @l : List A@ and a function @aliasOf : A -> A@, +-- compute a map @Map A (Set A)@ which records the set of things that are +-- transitive aliases of a given @a : A@. +-- +-- The keys in the resulting map should be only terminals, e.g. those @a@ +-- which aren't aliases of another @a'@ in @l@. +-- +-- Requires that the elements of the input sequence are unique. +-- +-- Outline: +-- * Initialize the empty map @M : Map A (Set A)@ +-- * Initialize an auxilary map @N : Map A A@ which records the final aliasee +-- of each key (the last one in the chain of aliases). +-- * For each @a : A@ in l, +-- 1. If @aliasOf a@ is in @N@ as @aliasee@, +-- a. insert @aliasee@ at key @a@ in @N@ (memoize the result) +-- b. insert @a@ into the set at key @aliasee@ in @M@ (record the result) +-- c. recurse on @s@ minus @aliasee@ and @a@. +-- 2. If @aliasOf a@ is in @s@, recurse on @l ++ [a]@ +-- 3. Otherwise, +-- a. insert @a@ at key @a@ in @N@ (memoize the result) +-- b. return the map as-is +-- +-- For the sake of practical concerns, the implementation uses \"labels\" for +-- comparison and @aliasOf@, and uses sequences rather than lists. +reverseAliases :: (Ord a, Ord l, Show a, Show l) + => (a -> l) -- ^ \"Label of\" + -> (a -> Maybe l) -- ^ \"Alias of\" + -> Seq a + -> Map a (Set a) +reverseAliases lab aliasOf_ seq_ = + evalState (go Map.empty seq_) (Map.empty :: Map l a) + + where go map_ Seq.Empty = pure map_ + go map_ (a Seq.:<| as) = + case aliasOf_ a of + Nothing -> + do -- Don't overwrite it if it's already in the map + modify (Map.insert (lab a) a) + go (Map.insertWith (\_ old -> old) a Set.empty map_) as + Just l -> + do when (lab a == l) $ + panic "reverseAliases" [ "Self-alias:", show a ] + st <- get + case Map.lookup l st of + Just aliasee -> + modify (Map.insert (lab a) aliasee) >> -- 1a + go (mapSetInsert aliasee a map_) -- 1b + (Seq.filter (\b -> lab b /= lab aliasee && lab b /= l) as) -- 1c + Nothing -> + if isJust (List.find ((l ==) . lab) as) + then go map_ (as <> Seq.singleton a) -- 2 + else modify (Map.insert (lab a) a) >> -- 3a + go map_ as -- 3b + where mapSetInsert k v m = Map.update (pure . Set.insert v) k m + +-- | This is one step closer to the application of 'reverseAliases': +-- There are two \"sorts\" of objects: +-- Objects in sort @a@ are never aliases (think global variables). +-- Objects in sort @b@ are usually aliases, to things of either sort +-- (think aliases to global variables). +reverseAliasesTwoSorted :: (Ord a, Ord b, Ord l, Show a, Show b, Show l) + => (a -> l) -- ^ \"Label of\" for type @a@ + -> (b -> l) -- ^ \"Label of\" for type @b@ + -> (b -> Maybe l) -- ^ \"Alias of\" + -> Seq a + -> Seq b + -> Map a (Set b) +reverseAliasesTwoSorted laba labb aliasOf_ seqa seqb = + Map.fromList . mapMaybe go . Map.toList $ + reverseAliases (either laba labb) + (either (const Nothing) aliasOf_) + (fmap Left seqa <> fmap Right seqb) + where -- Drop the b's which have been added as keys and + go (Right _, _) = Nothing + -- Call "error" if an a has been tagged as an alias + go (Left k, s) = Just (k, Set.map errLeft s) + -- TODO: Should this throw an exception? + errLeft (Left _) = error "Internal error: unexpected Left value" + errLeft (Right v) = v + +-- | What does this alias point to? +aliasOf :: (?lc :: TypeContext, HasPtrWidth wptr) + => L.GlobalAlias + -> Maybe L.Symbol +aliasOf alias = + case L.aliasTarget alias of + L.ValSymbol symb -> Just symb + L.ValConstExpr constExpr -> + case transConstantExpr constExpr of + Right (SymbolConst symb 0) -> Just symb + _ -> Nothing + -- All other things silently get dropped; it's invalid LLVM code to not have + -- a symbol or constexpr. + _ -> Nothing + +-- | Get all the aliases that alias (transitively) to a certain global. +globalAliases :: (?lc :: TypeContext, HasPtrWidth wptr) + => L.Module + -> Map L.Symbol (Set L.GlobalAlias) +globalAliases mod_ = Map.mapKeys L.globalSym $ + reverseAliasesTwoSorted L.globalSym L.aliasName aliasOf + (Seq.fromList (L.modGlobals mod_)) (Seq.fromList (L.modAliases mod_)) + +-- | Get all the aliases that alias (transitively) to a certain function. +functionAliases :: (?lc :: TypeContext, HasPtrWidth wptr) + => L.Module + -> Map L.Symbol (Set L.GlobalAlias) +functionAliases mod_ = Map.mapKeys L.defName $ + reverseAliasesTwoSorted L.defName L.aliasName aliasOf + (Seq.fromList (L.modDefines mod_)) (Seq.fromList (L.modAliases mod_)) diff --git a/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs b/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/BlockInfo.hs @@ -0,0 +1,321 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.BlockInfo +-- Description : Pre-translation analysis results +-- Copyright : (c) Galois, Inc 2018-2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +----------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Translation.BlockInfo + ( LLVMBlockInfoMap + , LLVMBlockInfo(..) + , buildBlockInfoMap + , useTypedVal + ) where + +import Data.Foldable (toList) +import Data.List (foldl') +import Data.Maybe +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set + +import qualified Text.LLVM.AST as L + +import Lang.Crucible.CFG.Generator +import Lang.Crucible.Panic ( panic ) + +type LLVMBlockInfoMap s = Map L.BlockLabel (LLVMBlockInfo s) + +-- | Information about an LLVM basic block computed before we begin the +-- translation proper. +data LLVMBlockInfo s + = LLVMBlockInfo + { + -- | The crucible block label corresponding to this LLVM block + block_label :: Label s + + -- | The computed \"use\" set for this block. This is the set + -- of identifiers that must be assigned prior to jumping to this + -- block. They are either used directly in this block or used + -- by a successor of this block. + -- + -- Note! \"metadata\" nodes do not contribute to the use set. + -- This is because LLVM itself relaxes the usual use/def rules + -- for metadata to prevent debugging information from inhibiting + -- optimizations. CF https://bugs.llvm.org/show_bug.cgi?id=51155 + -- + -- Note! values referenced in phi nodes are also not included in + -- this set, they are instead handled when examining the + -- terminal statements of predecessor blocks. + , block_use_set :: !(Set L.Ident) + + -- | The predecessor blocks to this block (i.e., all those blocks + -- that can jump to this one). + , block_pred_set :: !(Set L.BlockLabel) + + -- | The successor blocks to this block (i.e., all those blocks + -- that this block can jump to). + , block_succ_set :: !(Set L.BlockLabel) + + -- | The statements defining this block + , block_body :: ![L.Stmt] + + -- | Map from labels to assignments that must be made before + -- jumping. If this is the block info for label l', + -- and the map has [(i1,v1),(i2,v2)] in the phi_map for block l, + -- then basic block l is required to assign i1 = v1 and i2 = v2 + -- before jumping to block l'. + , block_phi_map :: !(Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value))) + } + +-- | Construct the block info map for the given function definition. This collects +-- information about phi-nodes, assigns crucible labels to each basic block, and +-- computes use sets for each block. +buildBlockInfoMap :: Monad m => L.Define -> Generator l s st ret m (LLVMBlockInfoMap s) +buildBlockInfoMap d = + do bim0 <- Map.fromList <$> (mapM buildBlockInfo $ L.defBody d) + let bim1 = updatePredSets bim0 + return (computeUseSets bim1) + +-- | Build the initial pass of block information. This does not yet compute predecessor +-- sets or use sets. +buildBlockInfo :: Monad m => L.BasicBlock -> Generator l s st ret m (L.BlockLabel, LLVMBlockInfo s) +buildBlockInfo bb = do + let phi_map = buildPhiMap (L.bbStmts bb) + let succ_set = buildSuccSet (L.bbStmts bb) + let blk_lbl = case L.bbLabel bb of + Just l -> l + Nothing -> panic "crucible-llvm:Translation.buildBlockInfo" + [ "unable to obtain label from BasicBlock" ] + lab <- newLabel + return (blk_lbl, LLVMBlockInfo{ block_phi_map = phi_map + , block_use_set = mempty + , block_pred_set = mempty + , block_succ_set = succ_set + , block_body = L.bbStmts bb + , block_label = lab + }) + +-- | Given the statements in a basic block, find all the successor blocks, +-- i.e. the blocks this one may jump to. +buildSuccSet :: [L.Stmt] -> Set L.BlockLabel +buildSuccSet [] = mempty +buildSuccSet (s:ss) = + case L.stmtInstr s of + L.Ret{} -> mempty + L.RetVoid -> mempty + L.Unreachable -> mempty + L.Jump l -> Set.singleton l + L.Br _ l1 l2 -> Set.fromList [l1,l2] + L.CallBr _ _ _ norm other -> Set.fromList (norm:other) + L.Invoke _ _ _ l1 l2 -> Set.fromList [l1,l2] + L.IndirectBr _ ls -> Set.fromList ls + L.Switch _ ldef ls -> Set.fromList (ldef:map snd ls) + _ -> buildSuccSet ss + + +-- | Compute predecessor sets from the successor sets already computed in @buildBlockInfo@ +updatePredSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s +updatePredSets bim0 = foldl' upd bim0 predEdges + where + upd bim (to,from) = Map.adjust (\bi -> bi{ block_pred_set = Set.insert from (block_pred_set bi) }) to bim + + predEdges = + [ (to,from) | (from, bi) <- Map.assocs bim0 + , to <- Set.elems (block_succ_set bi) + ] + +-- | Compute use sets for each basic block. These sets list all the +-- virtual registers that must be assigned before jumping to a +-- block. +-- +-- This is essentially a backward fixpoint computation based on the +-- identifiers used in the block statements. We iterate the use/def +-- transfer function until no more changes are made. Because it is a +-- backward analysis, we (heuristically) examine the blocks in +-- descending order, and re-add blocks to the workset based on +-- predecessor maps. +-- +-- This fixpoint computation terminates for the usual reasons: the transfer +-- function is monotonic (use sets only increase) and has no infinite +-- chains (in the worst case, all the finitely-many identifiers in the +-- function end up in every use set). +computeUseSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s +computeUseSets bim0 = loop bim0 (Map.keysSet bim0) -- start with all blocks in the workset + where + loop bim ws = + -- choose the largest remaining block label in the workset + case Set.maxView ws of + -- if the workset is empty, we are done + Nothing -> bim + Just (l, ws') -> + -- look up the current block information relating to block l + case Map.lookup l bim of + Nothing -> panic "computeUseSets" ["Could not find label", show l] + Just bi -> + -- run the transfer function and compute an updated use set + case updateUseSet l bi bim of + -- if there is no update, continue down the work set + Nothing -> loop bim ws' + -- if we updated the use set, record it in the block map and + -- add all the predecessors of this block back to the work set + Just bi' -> + loop (Map.insert l bi' bim) (Set.union ws' (block_pred_set bi')) + +-- | Run the use/def transfer function on the block body and update the block info if +-- any changes are detected +updateUseSet :: L.BlockLabel -> LLVMBlockInfo s -> Map L.BlockLabel (LLVMBlockInfo s) -> Maybe (LLVMBlockInfo s) +updateUseSet lab bi bim = if newuse == block_use_set bi then Nothing else Just bi{ block_use_set = newuse } + where + newuse = loop (block_body bi) + + loop [] = mempty + + -- invoke and callbr are a special case when their return values are assigned + -- to registers: the return values can only be used in the "normal" successor + -- block. + + loop (L.Result nm i _md:ss) = + case i of + L.Invoke _tp f args l_normal l_unwind -> + -- the use sets from the function value, arguments, and unwind label + let uss = [useVal f, useLabel lab l_unwind bim] ++ map useTypedVal args + -- the use set from the normal return label, note that nm is in scope here + u_normal = Set.delete nm (useLabel lab l_normal bim) + -- invoke is a block terminator, we can ignore the tail of the list + in Set.unions (u_normal : uss) + + L.CallBr _tp f args l_normal ls -> + -- the use sets from the function value, arguments, and non-normal + -- labels + let uss = useVal f:(map (\l -> useLabel lab l bim) ls ++ map useTypedVal args) + -- the use set from the normal return label, note that nm is in scope here + u_normal = Set.delete nm (useLabel lab l_normal bim) + -- callbr is a block terminator, we can ignore the tail of the list + in Set.unions (u_normal : uss) + + -- In other cases, combine the use set of the instruction with + -- the use set of following instructions, after deleting the register + -- defined here + _ -> Set.union (instrUse lab i bim) (Set.delete nm (loop ss)) + + loop (L.Effect i _md:ss) = Set.union (instrUse lab i bim) (loop ss) + +instrUse :: L.BlockLabel -> L.Instr -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident +instrUse from i bim = Set.unions $ case i of + L.Phi{} -> [] -- NB, phi node use is handled in `useLabel` + L.RetVoid -> [] + L.Ret tv -> [useTypedVal tv] + L.Arith _op x y -> [useTypedVal x, useVal y] + L.Bit _op x y -> [useTypedVal x, useVal y ] + L.Conv _op x _tp -> [useTypedVal x] + L.Call _tailCall _tp f args -> useVal f : map useTypedVal args + -- NB, this is only correct for "callbr" instructions that don't assign the return value + L.CallBr _tp f args norm ls -> + [useVal f, useLabel from norm bim] ++ + map (\l -> useLabel from l bim) ls ++ + map useTypedVal args + L.Alloca _tp Nothing _align -> [] + L.Alloca _tp (Just x) _align -> [useTypedVal x] + L.Load _tp p _ord _align -> [useTypedVal p] + L.Store p v _ord _align -> [useTypedVal p, useTypedVal v] + L.Fence{} -> [] + L.CmpXchg _weak _vol p v1 v2 _s _o1 _o2 -> map useTypedVal [p,v1,v2] + L.AtomicRW _vol _op p v _s _o -> [useTypedVal p, useTypedVal v] + L.ICmp _op x y -> [useTypedVal x, useVal y] + L.FCmp _op x y -> [useTypedVal x, useVal y] + L.GEP _ib _tp base args -> useTypedVal base : map useTypedVal args + L.Select c x y -> [ useTypedVal c, useTypedVal x, useVal y ] + L.ExtractValue x _ixs -> [useTypedVal x] + L.InsertValue x y _ixs -> [useTypedVal x, useTypedVal y] + L.ExtractElt x y -> [useTypedVal x, useVal y] + L.InsertElt x y z -> [useTypedVal x, useTypedVal y, useVal z] + L.ShuffleVector x y z -> [useTypedVal x, useVal y, useTypedVal z] + L.Jump l -> [useLabel from l bim] + L.Br c l1 l2 -> [useTypedVal c, useLabel from l1 bim, useLabel from l2 bim] + -- NB, this is only correct for "invoke" instructions that don't assign the return value + L.Invoke _tp f args l1 l2 -> [useVal f, useLabel from l1 bim, useLabel from l2 bim] ++ map useTypedVal args + L.Comment{} -> [] + L.Unreachable -> [] + L.Unwind -> [] -- ?? + L.VaArg x _tp -> [useTypedVal x] + L.IndirectBr x ls -> useTypedVal x : [ useLabel from l bim | l <- ls ] + L.Switch c def bs -> useTypedVal c : useLabel from def bim : [ useLabel from l bim | (_,l) <- bs ] + L.Resume x -> [useTypedVal x] + L.LandingPad _tp Nothing _ cls -> map useClause cls + L.LandingPad _tp (Just cleanup) _ cls -> useTypedVal cleanup : map useClause cls + L.UnaryArith _op x -> [useTypedVal x] + L.Freeze x -> [useTypedVal x] + +useClause :: L.Clause -> Set L.Ident +useClause (L.Catch v) = useTypedVal v +useClause (L.Filter v) = useTypedVal v + +useLabel :: L.BlockLabel -> L.BlockLabel -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident +useLabel from to bim = + case Map.lookup to bim of + Nothing -> panic "useLabel" ["Could not find label", show to] + Just bi -> + let phiList = + case Map.lookup from (block_phi_map bi) of + Nothing -> [] + Just ps -> toList ps + in Set.unions (block_use_set bi : [ useVal v | (_,_,v) <- phiList ]) + +-- | Compute the set of identifiers referenced by the given typed value +useTypedVal :: L.Typed (L.Value) -> Set L.Ident +useTypedVal tv = useVal (L.typedValue tv) + +-- | Compute the set of identifiers referenced by the given value +useVal :: L.Value -> Set L.Ident +useVal v = Set.unions $ case v of + L.ValInteger{} -> [] + L.ValBool{} -> [] + L.ValFloat{} -> [] + L.ValDouble{} -> [] + L.ValFP80{} -> [] + L.ValIdent i -> [Set.singleton i] + L.ValSymbol _s -> [] + L.ValNull -> [] + L.ValArray _tp vs -> map useVal vs + L.ValVector _tp vs -> map useVal vs + L.ValStruct vs -> map useTypedVal vs + L.ValPackedStruct vs -> map useTypedVal vs + L.ValString _ -> [] + L.ValConstExpr{} -> [] -- TODO? should we look through constant exprs? + L.ValUndef -> [] + L.ValLabel _ -> [] + L.ValZeroInit -> [] + L.ValAsm{} -> [] -- TODO! inline asm ... + L.ValPoison{} -> [] + + -- NB! metadata values are not considered as part of our use analysis + L.ValMd _md -> [] + + +-- | Given the statements in a basic block, find all the phi instructions and +-- compute the list of assignments that must be made for each predecessor block. +buildPhiMap :: [L.Stmt] -> Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value)) +buildPhiMap ss = go ss Map.empty + where go (L.Result ident (L.Phi tp xs) _ : stmts) m = go stmts (go' ident tp xs m) + go _ m = m + + f x mseq = Just (fromMaybe Seq.empty mseq Seq.|> x) + + go' ident tp ((v, lbl) : xs) m = go' ident tp xs (Map.alter (f (ident,tp,v)) lbl m) + go' _ _ [] m = m diff --git a/src/Lang/Crucible/LLVM/Translation/Constant.hs b/src/Lang/Crucible/LLVM/Translation/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Constant.hs @@ -0,0 +1,1204 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Constant +-- Description : LLVM constant expression evaluation and GEPs +-- Copyright : (c) Galois, Inc 2014-2015 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module provides translation-time evaluation of constant +-- expressions. It also provides an intermediate representation +-- for GEP (getelementpointer) instructions that makes more explicit +-- the places where vectorization may occur, as well as resolving type +-- sizes and field offsets. +-- +-- See @liftConstant@ for how to turn these into expressions. +----------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Translation.Constant + ( -- * Representation of LLVM constant values + LLVMConst(..) + , boolConst + , intConst + + -- * Translations from LLVM syntax to constant values + , transConstant + , transConstantWithType + , transConstant' + , transConstantExpr + + -- * Intermediate representation for GEP + , GEP(..) + , GEPResult(..) + , translateGEP + + -- * Utility functions + , showInstr + , testBreakpointFunction + ) where + +import Control.Lens( to, (^.) ) +import Control.Monad +import Control.Monad.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Bits +import Data.Kind +import Data.List (intercalate, isPrefixOf) +import Data.Traversable +import Data.Fixed (mod') +import qualified Data.Vector as V +import Numeric.Natural +import GHC.TypeNats + +import qualified Text.LLVM.AST as L +import qualified Text.LLVM.PP as L + +import qualified Data.BitVector.Sized as BV +import qualified Data.BitVector.Sized.Overflow as BV +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import Data.Parameterized.DecidableEq (decEq) + +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout( intLayout, EndianForm(..) ) +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemType +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext + +-- | Pretty print an LLVM instruction +showInstr :: L.Instr -> String +showInstr i = show (L.ppLLVM38 (L.ppInstr i)) + +-- | Intermediate representation of a GEP. +-- A @GEP n expr@ is a representation of a GEP with +-- @n@ parallel vector lanes with expressions represented +-- by @expr@ values. +data GEP (n :: Nat) (expr :: Type) where + -- | Start a GEP with a single base pointer + GEP_scalar_base :: expr -> GEP 1 expr + + -- | Start a GEP with a vector of @n@ base pointers + GEP_vector_base :: NatRepr n -> expr -> GEP n expr + + -- | Copy a scalar base vector pointwise into a + -- vector of length @n@. + GEP_scatter :: NatRepr n -> GEP 1 expr -> GEP n expr + + -- | Add the offset corresponding to the given field + -- pointwise to each pointer + GEP_field :: FieldInfo -> GEP n expr -> GEP n expr + + -- | Add an offset corresponding to the given array index + -- (multiplied by the given type size) pointwise to the pointers + -- in each lane. + GEP_index_each :: MemType -> GEP n expr -> expr -> GEP n expr + + -- | Given a vector of offsets (whose length must match + -- the number of lanes), multiply each one by the + -- type size, and add the offsets to the corresponding + -- pointers. + GEP_index_vector :: MemType -> GEP n expr -> expr -> GEP n expr + +instance Functor (GEP n) where + fmap = fmapDefault +instance Foldable (GEP n) where + foldMap = foldMapDefault + +instance Traversable (GEP n) where + traverse f gep = case gep of + GEP_scalar_base x -> GEP_scalar_base <$> f x + GEP_vector_base n x -> GEP_vector_base n <$> f x + GEP_scatter n gep' -> GEP_scatter n <$> traverse f gep' + GEP_field fi gep' -> GEP_field fi <$> traverse f gep' + GEP_index_each mt gep' idx -> GEP_index_each mt <$> traverse f gep' <*> f idx + GEP_index_vector mt gep' idx -> GEP_index_vector mt <$> traverse f gep' <*> f idx + +-- | The result of a GEP instruction translation. It records the number +-- of parallel vector lanes in the resulting instruction, the resulting +-- memory type of the instruction, and the sequence of sub-operations +-- required to compute the GEP instruction. +data GEPResult expr where + GEPResult :: (1 <= n) => NatRepr n -> MemType -> GEP n expr -> GEPResult expr + +instance Functor GEPResult where + fmap = fmapDefault +instance Foldable GEPResult where + foldMap = foldMapDefault + +instance Traversable GEPResult where + traverse f (GEPResult n mt gep) = GEPResult n mt <$> traverse f gep + + +-- | Given the data for an LLVM getelementpointer instruction, +-- preprocess the instruction into a @GEPResult@, checking +-- types, computing vectorization lanes, etc. +-- +-- As a concrete example, consider a call to +-- @'translateGEP' inbounds baseTy basePtr elts@ with the following +-- instruction: +-- +-- @ +-- getelementptr [12 x i8], ptr %aptr, i64 0, i32 1 +-- @ +-- +-- Here: +-- +-- * @inbounds@ is 'False', as the keyword of the same name is missing from +-- the instruction. (Currently, @crucible-llvm@ ignores this information.) +-- +-- * @baseTy@ is @[12 x i8]@. This is the type used as the basis for +-- subsequent calculations. +-- +-- * @basePtr@ is @ptr %aptr@. This pointer is used as the base address to +-- start calculations from. Note that the type of @basePtr@ is /not/ +-- @baseTy@, but rather a pointer type. +-- +-- * The @elts@ are @[i64 0, i32 1]@. These are the indices that indicate +-- which of the elements of the aggregate object are indexed. +translateGEP :: forall wptr m. + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + Bool {- ^ inbounds flag -} -> + L.Type {- ^ base type for calculations -} -> + L.Typed L.Value {- ^ base pointer expression -} -> + [L.Typed L.Value] {- ^ index arguments -} -> + m (GEPResult (L.Typed L.Value)) + +translateGEP _ _ _ [] = + throwError "getelementpointer must have at least one index" + +translateGEP inbounds baseTy basePtr elts = + do baseMemType <- liftMemType baseTy + mt <- liftMemType (L.typedType basePtr) + -- Input value to a GEP must have a pointer type (or be a vector of pointer + -- types), and the base type used for calculations must be representable + -- as a memory type. The resulting memory type drives the interpretation of + -- the GEP arguments. + case mt of + -- Vector base case, with as many lanes as there are input pointers + VecType n vmt + | isPointerMemType vmt + , Some lanes <- mkNatRepr n + , Just LeqProof <- isPosNat lanes + -> let mt' = ArrayType 0 baseMemType in + go lanes mt' (GEP_vector_base lanes basePtr) elts + + -- Scalar base case with exactly 1 lane + _ | isPointerMemType mt + -> let mt' = ArrayType 0 baseMemType in + go (knownNat @1) mt' (GEP_scalar_base basePtr) elts + + | otherwise + -> badGEP + where + badGEP :: m a + badGEP = throwError $ unlines [ "Invalid GEP", showInstr (L.GEP inbounds baseTy basePtr elts) ] + + -- This auxilary function builds up the intermediate GEP mini-instructions that compute + -- the overall GEP, as well as the resulting memory type of the final pointers and the + -- number of vector lanes eventually computed by the GEP. + go :: + (1 <= lanes) => + NatRepr lanes {- Number of lanes of the GEP so far -} -> + MemType {- Memory type of the incoming pointer(s) -} -> + GEP lanes (L.Typed L.Value) {- partial GEP computation -} -> + [L.Typed L.Value] {- remaining arguments to process -} -> + m (GEPResult (L.Typed L.Value)) + + -- Final step, all arguments are used up, return the GEPResult + go lanes mt gep [] = return (GEPResult lanes mt gep) + + -- Resolve one offset value and recurse + go lanes mt gep (off:xs) = + do offt <- liftMemType (L.typedType off) + -- The meaning of the offset depends on the static type of the intermediate result + case mt of + ArrayType _ mt' -> goArray lanes off offt mt' gep xs + VecType _ mt' -> goArray lanes off offt mt' gep xs + StructType si -> goStruct lanes off offt si gep xs + _ -> badGEP + + -- If it is an array type, the offset should be considered an array index, or + -- vector of array indices. + goArray :: + (1 <= lanes) => + NatRepr lanes {- Number of lanes of the GEP so far -} -> + L.Typed L.Value {- Current index value -} -> + MemType {- MemType of the index value -} -> + MemType {- MemType of the incoming pointer(s) -} -> + GEP lanes (L.Typed L.Value) {- partial GEP computation -} -> + [L.Typed L.Value] {- remaining arguments to process -} -> + m (GEPResult (L.Typed L.Value)) + goArray lanes off offt mt' gep xs = + case offt of + -- Single array index, apply pointwise to all intermediate pointers + IntType _ + -> go lanes mt' (GEP_index_each mt' gep off) xs + + -- Vector of indices, matching the current number of lanes, apply + -- each offset to the corresponding base pointer + VecType n (IntType _) + | natValue lanes == n + -> go lanes mt' (GEP_index_vector mt' gep off) xs + + -- Vector of indices, with a single incoming base pointer. Scatter + -- the base pointer across the correct number of lanes, and then + -- apply the vector of offsets componentwise. + VecType n (IntType _) + | Some n' <- mkNatRepr n + , Just LeqProof <- isPosNat n' + , Just Refl <- testEquality lanes (knownNat @1) + -> go n' mt' (GEP_index_vector mt' (GEP_scatter n' gep) off) xs + + -- Otherwise, some sort of mismatch occured. + _ -> badGEP + + -- If it is a structure type, the index must be a constant value that indicates + -- which field (counting from 0) is to be indexed. + goStruct :: + (1 <= lanes) => + NatRepr lanes {- Number of lanes of the GEP so far -} -> + L.Typed L.Value {- Field index number -} -> + MemType {- MemType of the field index -} -> + StructInfo {- Struct layout information -} -> + GEP lanes (L.Typed L.Value) {- partial GEP computation -} -> + [L.Typed L.Value] {- remaining arguments to process -} -> + m (GEPResult (L.Typed L.Value)) + goStruct lanes off offt si gep xs = + do off' <- transConstant' offt (L.typedValue off) + case off' of + -- Special case for the zero value + ZeroConst (IntType _) -> goidx 0 + + -- Single index; compute the corresponding field. + IntConst _ idx -> goidx (BV.asUnsigned idx) + + -- Special case. A vector of indices is allowed, but it must be of the correct + -- number of lanes, and each (constant) index must be the same value. + VectorConst (IntType _) (i@(IntConst _ idx) : is) | all (same i) is -> goidx (BV.asUnsigned idx) + where + same :: LLVMConst -> LLVMConst -> Bool + same (IntConst wx x) (IntConst wy y) + | Just Refl <- testEquality wx wy = x == y + same _ _ = False + + -- Otherwise, invalid GEP instruction + _ -> badGEP + + -- using the information from the struct type, figure out which + -- field is indicated + where goidx idx | 0 <= idx && idx < toInteger (V.length flds) = + go lanes (fiType fi) (GEP_field fi gep) xs + where flds = siFields si + fi = flds V.! (fromInteger idx) + + goidx _ = badGEP + + +-- | Translation-time LLVM constant values. +data LLVMConst where + -- | A constant value consisting of all zero bits. + ZeroConst :: !MemType -> LLVMConst + -- | A constant integer value, with bit-width @w@. + IntConst :: (1 <= w) => !(NatRepr w) -> !(BV.BV w) -> LLVMConst + -- | A constant floating point value. + FloatConst :: !Float -> LLVMConst + -- | A constant double value. + DoubleConst :: !Double -> LLVMConst + -- | A constant long double value (X86_FP80) + LongDoubleConst :: !L.FP80Value -> LLVMConst + -- | A constant sequence of bytes + StringConst :: !ByteString -> LLVMConst + -- | A constant array value. + ArrayConst :: !MemType -> [LLVMConst] -> LLVMConst + -- | A constant vector value. + VectorConst :: !MemType -> [LLVMConst] -> LLVMConst + -- | A constant structure value. + StructConst :: !StructInfo -> [LLVMConst] -> LLVMConst + -- | A pointer value, consisting of a concrete offset from a global symbol. + SymbolConst :: !L.Symbol -> !Integer -> LLVMConst + -- | The @undef@ value is quite strange. See: The LLVM Language Reference, + -- § Undefined Values. + UndefConst :: !MemType -> LLVMConst + + +-- | This also can't be derived, but is completely uninteresting. +instance Show LLVMConst where + show lc = intercalate " " $ + case lc of + (ZeroConst mem) -> ["ZeroConst", show mem] + (IntConst w x) -> ["IntConst", show w, show x] + (FloatConst f) -> ["FloatConst", show f] + (DoubleConst d) -> ["DoubleConst", show d] + ld@(LongDoubleConst _)-> ["LongDoubleConst", show ld] + (ArrayConst mem a) -> ["ArrayConst", show mem, show a] + (VectorConst mem v) -> ["VectorConst", show mem, show v] + (StructConst si a) -> ["StructConst", show si, show a] + (SymbolConst s x) -> ["SymbolConst", show s, show x] + (UndefConst mem) -> ["UndefConst", show mem] + (StringConst bs) -> ["StringConst", show bs] + +-- | The interesting cases here are: +-- * @IntConst@: GHC can't derive this because @IntConst@ existentially +-- quantifies the integer's width. We say that two integers are equal when +-- they have the same width *and* the same value. +-- * @UndefConst@: Two @undef@ values aren't necessarily the same... +instance Eq LLVMConst where + (ZeroConst mem1) == (ZeroConst mem2) = mem1 == mem2 + (IntConst w1 x1) == (IntConst w2 x2) = + case decEq w1 w2 of + Left Refl -> x1 == x2 + Right _ -> False + (FloatConst f1) == (FloatConst f2) = f1 == f2 + (DoubleConst d1) == (DoubleConst d2) = d1 == d2 + (LongDoubleConst ld1) == (LongDoubleConst ld2) = ld1 == ld2 + (ArrayConst mem1 a1) == (ArrayConst mem2 a2) = mem1 == mem2 && a1 == a2 + (VectorConst mem1 v1) == (VectorConst mem2 v2) = mem1 == mem2 && v1 == v2 + (StructConst si1 a1) == (StructConst si2 a2) = si1 == si2 && a1 == a2 + (SymbolConst s1 x1) == (SymbolConst s2 x2) = s1 == s2 && x1 == x2 + (UndefConst _) == (UndefConst _) = False + _ == _ = False + +-- | Create an LLVM constant value from a boolean. +boolConst :: Bool -> LLVMConst +boolConst False = IntConst (knownNat @1) (BV.zero knownNat) +boolConst True = IntConst (knownNat @1) (BV.one knownNat) + +-- | Create an LLVM constant of a given width. The resulting integer +-- constant value will be the unsigned integer value @n mod 2^w@. +intConst :: + MonadError String m => + Natural {- ^ width of the integer constant, @w@ -} -> + Integer {- ^ value of the integer constant, @n@ -} -> + m LLVMConst +intConst n 0 + = return (ZeroConst (IntType n)) +intConst n x + | Some w <- mkNatRepr n + , Just LeqProof <- isPosNat w + = return (IntConst w (BV.mkBV w x)) +intConst n _ + = throwError ("Invalid integer width: " ++ show n) + +-- | Compute the constant value of an expression. Fail if the +-- given value does not represent a constant. +transConstantWithType :: + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + L.Typed L.Value -> + m (MemType, LLVMConst) +transConstantWithType (L.Typed tp v) = + do mt <- liftMemType tp + c <- transConstant' mt v + return (mt, c) + +transConstant :: + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + L.Typed L.Value -> + m LLVMConst +transConstant x = snd <$> transConstantWithType x + +-- | Compute the constant value of an expression. Fail if the +-- given value does not represent a constant. +transConstant' :: + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + MemType -> + L.Value -> + m LLVMConst +transConstant' tp (L.ValUndef) = + return (UndefConst tp) +transConstant' (IntType n) (L.ValInteger x) = + intConst n x +transConstant' (IntType 1) (L.ValBool b) = + return . IntConst (knownNat @1) $ if b + then (BV.one knownNat) + else (BV.zero knownNat) +transConstant' FloatType (L.ValFloat f) = + return (FloatConst f) +transConstant' DoubleType (L.ValDouble d) = + return (DoubleConst d) +transConstant' X86_FP80Type (L.ValFP80 ld) = + return (LongDoubleConst ld) +transConstant' (PtrType _) (L.ValSymbol s) = + return (SymbolConst s 0) +transConstant' PtrOpaqueType (L.ValSymbol s) = + return (SymbolConst s 0) +transConstant' tp L.ValZeroInit = + return (ZeroConst tp) +transConstant' (PtrType stp) L.ValNull = + return (ZeroConst (PtrType stp)) +transConstant' PtrOpaqueType L.ValNull = + return (ZeroConst PtrOpaqueType) +transConstant' (VecType n tp) (L.ValVector _tp xs) + | n == fromIntegral (length xs) + = VectorConst tp <$> traverse (transConstant' tp) xs +transConstant' (ArrayType n tp) (L.ValArray _tp xs) + | n == fromIntegral (length xs) + = ArrayConst tp <$> traverse (transConstant' tp) xs +transConstant' (StructType si) (L.ValStruct xs) + | not (siIsPacked si) + , V.length (siFields si) == length xs + = StructConst si <$> traverse transConstant xs +transConstant' (StructType si) (L.ValPackedStruct xs) + | siIsPacked si + , V.length (siFields si) == length xs + = StructConst si <$> traverse transConstant xs + +transConstant' (ArrayType n tp) (L.ValString cs) + | tp == IntType 8, n == fromIntegral (length cs) + = return . StringConst $! BS.pack cs + +transConstant' _ (L.ValConstExpr cexpr) = transConstantExpr cexpr + +transConstant' tp val = + throwError $ unlines [ "Cannot compute constant value for expression: " + , "Type: " ++ (show $ ppMemType tp) + , "Value: " ++ (show $ LPP.ppValue val) + ] + + +-- | Evaluate a GEP instruction to a constant value. +evalConstGEP :: forall m wptr. + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + GEPResult LLVMConst -> + m (MemType, LLVMConst) +evalConstGEP (GEPResult lanes finalMemType gep0) = + do xs <- go gep0 + unless (fromIntegral (length xs) == natValue lanes) + (throwError "Unexpected vector length in result of constant GEP") + case xs of + [x] -> return ( PtrType (MemType finalMemType), x) + _ -> return ( VecType (fromIntegral (length xs)) (PtrType (MemType finalMemType)) + , VectorConst (PtrType (MemType finalMemType)) xs + ) + + where + dl = llvmDataLayout ?lc + + asOffset :: MemType -> LLVMConst -> m Integer + asOffset _ (ZeroConst (IntType _)) = return 0 + asOffset mt (IntConst _ x) = + do let x' = BV.asUnsigned x * bytesToInteger (memTypeSize dl mt) + unless (x' <= maxUnsigned ?ptrWidth) + (throwError "Computed offset overflow in constant GEP") + return x' + asOffset ty val = throwError $ unlines $ + [ "Expected offset value in constant GEP" + , "Type: " ++ show ty + , "Offset: " ++ show val + ] + + addOffset :: Integer -> LLVMConst -> m LLVMConst + addOffset x (SymbolConst sym off) = return (SymbolConst sym (off+x)) + addOffset _ constant = throwError $ unlines $ + [ "Expected symbol constant in constant GEP" + , "Constant: " ++ show constant + ] + + -- Given a processed GEP instruction, compute the sequence of output + -- pointer values that result from the instruction. If the GEP is + -- scalar-valued, then the result will be a list of one element. + go :: GEP n LLVMConst -> m [LLVMConst] + + -- Scalar base, return a list containing just the base value. + go (GEP_scalar_base base) + = return [base] + + -- Vector base, deconstruct the input value and return the + -- corresponding values. + go (GEP_vector_base n x) + = asVectorOf (natValue n) return x + + -- Scatter a scalar input across n lanes + go (GEP_scatter n gep) + = do ps <- go gep + case ps of + [p] -> return (replicate (widthVal n) p) + _ -> throwError "vector length mismatch in GEP scatter" + + -- Add the offset corresponding to the given field across + -- all the lanes of the GEP + go (GEP_field fi gep) + = do ps <- go gep + let i = bytesToInteger (fiOffset fi) + traverse (addOffset i) ps + + -- Compute the offset corresponding to the given array index + -- and add that offest across all the lanes of the GEP + go (GEP_index_each mt gep x) + = do ps <- go gep + i <- asOffset mt x + traverse (addOffset i) ps + + -- For each index in the input vector, compute and offset according + -- to the given memory type and add the corresponding offset across + -- each lane of the GEP componentwise. + go (GEP_index_vector mt gep x) + = do ps <- go gep + is <- asVectorOf (fromIntegral (length ps)) (asOffset mt) x + zipWithM addOffset is ps + +-- | Evaluate a floating point comparison. +evalFcmp :: + RealFloat a => + L.FCmpOp -> + a -> a -> LLVMConst +evalFcmp op x y = boolConst $ case op of + L.Ffalse -> False + L.Ftrue -> True + L.Foeq -> ordered && x == y + L.Fone -> ordered && x /= y + L.Fogt -> ordered && x > y + L.Foge -> ordered && x >= y + L.Folt -> ordered && x < y + L.Fole -> ordered && x <= y + L.Ford -> ordered + L.Fueq -> unordered || x == y + L.Fune -> unordered || x /= y + L.Fugt -> unordered || x > y + L.Fuge -> unordered || x >= y + L.Fult -> unordered || x < y + L.Fule -> unordered || x <= y + L.Funo -> unordered + where + unordered = isNaN x || isNaN y + ordered = not unordered + +-- | Evaluate an integer comparison. +evalIcmp :: + (1 <= w) => + L.ICmpOp -> + NatRepr w -> + BV.BV w -> BV.BV w -> LLVMConst +evalIcmp op w x y = boolConst $ case op of + L.Ieq -> x == y + L.Ine -> x /= y + L.Iugt -> BV.ult y x + L.Iuge -> BV.ule y x + L.Iult -> BV.ult x y + L.Iule -> BV.ule x y + L.Isgt -> BV.slt w y x + L.Isge -> BV.sle w y x + L.Islt -> BV.slt w x y + L.Isle -> BV.sle w x y + +-- | Evaluate a binary arithmetic operation. +evalArith :: + (MonadError String m, HasPtrWidth wptr) => + L.ArithOp -> + MemType -> + Arith -> Arith -> m LLVMConst +evalArith op (IntType m) (ArithI x) (ArithI y) + | Just (Some w) <- someNat m + , Just LeqProof <- isPosNat w + = evalIarith op w x y +evalArith op FloatType (ArithF x) (ArithF y) = FloatConst <$> evalFarith op x y +evalArith op DoubleType (ArithD x) (ArithD y) = DoubleConst <$> evalFarith op x y +evalArith _ _ _ _ = throwError "binary arithmetic argument mismatch" + +-- | Evaluate a unary arithmetic operation. +evalUnaryArith :: + (MonadError String m, HasPtrWidth wptr) => + L.UnaryArithOp -> + MemType -> + Arith -> m LLVMConst +evalUnaryArith op FloatType (ArithF x) = FloatConst <$> evalFunaryArith op x +evalUnaryArith op DoubleType (ArithD x) = DoubleConst <$> evalFunaryArith op x +evalUnaryArith _ _ _ = throwError "unary arithmetic argument mismatch" + +-- | Evaluate a binary floating-point operation. +evalFarith :: + (RealFrac a, MonadError String m) => + L.ArithOp -> + a -> a -> m a +evalFarith op x y = + case op of + L.FAdd -> return (x + y) + L.FSub -> return (x - y) + L.FMul -> return (x * y) + L.FDiv -> return (x / y) + L.FRem -> return (mod' x y) + _ -> throwError "Encountered integer arithmetic operation applied to floating point arguments" + +-- | Evaluate a unary floating-point operation. +evalFunaryArith :: + (RealFrac a, MonadError String m) => + L.UnaryArithOp -> + a -> m a +evalFunaryArith op x = + case op of + L.FNeg -> return (negate x) + +-- | Evaluate an integer or pointer arithmetic operation. +evalIarith :: + (1 <= w, MonadError String m, HasPtrWidth wptr) => + L.ArithOp -> + NatRepr w -> + ArithInt -> ArithInt -> m LLVMConst +evalIarith op w (ArithInt x) (ArithInt y) + = IntConst w <$> evalIarith' op w (BV.mkBV w x) (BV.mkBV w y) +evalIarith op w (ArithPtr sym x) (ArithInt y) + | Just Refl <- testEquality w ?ptrWidth + , L.Add _ _ <- op + = return $ SymbolConst sym (x+y) + | otherwise + = throwError "Illegal operation applied to pointer argument" +evalIarith op w (ArithInt x) (ArithPtr sym y) + | Just Refl <- testEquality w ?ptrWidth + , L.Add _ _ <- op + = return $ SymbolConst sym (x+y) + | otherwise + = throwError "Illegal operation applied to pointer argument" +evalIarith op w (ArithPtr symx x) (ArithPtr symy y) + | Just Refl <- testEquality w ?ptrWidth + , symx == symy + , L.Sub _ _ <- op + = return $ IntConst ?ptrWidth (BV.mkBV ?ptrWidth (x - y)) + | otherwise + = throwError "Illegal operation applied to pointer argument" + +-- | Evaluate an integer (non-pointer) arithmetic operation. +evalIarith' :: + (1 <= w, MonadError String m) => + L.ArithOp -> + NatRepr w -> + BV.BV w -> BV.BV w -> m (BV.BV w) +evalIarith' op w x y = do + let nuwTest nuw zres = + when (nuw && BV.ofUnsigned zres) + (throwError "Unsigned overflow in constant arithmetic operation") + let nswTest nsw zres = + when (nsw && BV.ofSigned zres) + (throwError "Signed overflow in constant arithmetic operation") + case op of + L.Add nuw nsw -> + do let zres = BV.addOf w x y + nuwTest nuw zres + nswTest nsw zres + return (BV.ofResult zres) + + L.Sub nuw nsw -> + do let zres = BV.subOf w x y + nuwTest nuw zres + nswTest nsw zres + return (BV.ofResult zres) + + L.Mul nuw nsw -> + do let zres = BV.mulOf w x y + nuwTest nuw zres + nswTest nsw zres + return (BV.ofResult zres) + + L.UDiv exact -> + do when (y == BV.zero w) + (throwError "Division by 0 in constant arithmetic operation") + let (z,r) = BV.uquotRem x y + when (exact && r /= BV.zero w) + (throwError "Exact division failed in constant arithmetic operation") + return z + + L.SDiv exact -> + do when (y == BV.zero w) + (throwError "Division by 0 in constant arithmetic operation") + when (x == BV.minSigned w && y == BV.mkBV w (-1)) + (throwError "Signed division overflow in constant arithmetic operation") + let (z,r) = BV.squotRem w x y + when (exact && r /= BV.zero w ) + (throwError "Exact division failed in constant arithmetic operation") + return z + L.URem -> + do when (y == BV.zero w) + (throwError "Division by 0 in constant arithmetic operation") + let r = BV.urem x y + return r + + L.SRem -> + do when (y == BV.zero w) + (throwError "Division by 0 in constant arithmetic operation") + when (x == BV.minSigned w && y == BV.mkBV w (-1)) + (throwError "Signed division overflow in constant arithmetic operation") + let r = BV.srem w x y + return r + + _ -> throwError "Floating point operation applied to integer arguments" + +-- BGS: Leave this alone for now, as we don't have a good way to +-- detect overflow from bitvector operations. +-- | Evaluate a bitwise operation on integer values. +evalBitwise :: + (1 <= w, MonadError String m) => + L.BitOp -> + NatRepr w -> + BV.BV w -> BV.BV w -> m LLVMConst +evalBitwise op w x y = IntConst w <$> + let yshf = fromInteger (BV.asUnsigned y) :: Natural + in case op of + L.And -> return (BV.and x y) + L.Or -> return (BV.or x y) + L.Xor -> return (BV.xor x y) + L.Shl nuw nsw -> + do let zres = BV.shlOf w x yshf + when (nuw && BV.ofUnsigned zres) + (throwError "Unsigned overflow in left shift") + when (nsw && BV.ofSigned zres) + (throwError "Signed overflow in left shift") + return (BV.ofResult zres) + L.Lshr exact -> + do let z = BV.lshr w x yshf + when (exact && x /= BV.shl w z yshf) + (throwError "Exact right shift failed") + return z + L.Ashr exact -> + do let z = BV.ashr w x yshf + when (exact && x /= BV.shl w z yshf) + (throwError "Exact right shift failed") + return z + +-- | Evaluate a conversion operation on constants. +evalConv :: + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + L.ConstExpr -> + L.ConvOp -> + MemType -> + LLVMConst -> + m LLVMConst +evalConv expr op mt x = case op of + L.FpToUi + | IntType n <- mt + , Just (Some w) <- someNat n + , Just LeqProof <- isPosNat w + , FloatConst f <- x + -> return $ IntConst w (BV.mkBV w (truncate f)) + + | IntType n <- mt + , Just (Some w) <- someNat n + , Just LeqProof <- isPosNat w + , DoubleConst d <- x + -> return $ IntConst w (BV.mkBV w (truncate d)) + + L.FpToSi + | IntType n <- mt + , Just (Some w) <- someNat n + , Just LeqProof <- isPosNat w + , FloatConst f <- x + -> return $ IntConst w (BV.mkBV w (truncate f)) + + | IntType n <- mt + , Just (Some w) <- someNat n + , Just LeqProof <- isPosNat w + , DoubleConst d <- x + -> return $ IntConst w (BV.mkBV w (truncate d)) + + L.UiToFp + | FloatType <- mt + , IntConst _w i <- x + -> return $ FloatConst (fromInteger (BV.asUnsigned i) :: Float) + + | DoubleType <- mt + , IntConst _w i <- x + -> return $ DoubleConst (fromInteger (BV.asUnsigned i) :: Double) + + L.SiToFp + | FloatType <- mt + , IntConst w i <- x + -> return $ FloatConst (fromInteger (BV.asSigned w i) :: Float) + + | DoubleType <- mt + , IntConst w i <- x + -> return $ DoubleConst (fromInteger (BV.asSigned w i) :: Double) + + L.Trunc + | IntType n <- mt + , IntConst w i <- x + , Just (Some w') <- someNat n + , Just LeqProof <- isPosNat w' + -> case testNatCases w' w of + NatCaseLT LeqProof -> return $ IntConst w' (BV.trunc w' i) + NatCaseEQ -> return x + NatCaseGT LeqProof -> + throwError $ "Attempted to truncate " <> show w <> " bits to " <> show w' + + L.ZExt + | IntType n <- mt + , IntConst w i <- x + , Just (Some w') <- someNat n + , Just LeqProof <- isPosNat w' + -> case testNatCases w w' of + NatCaseLT LeqProof -> return $ IntConst w' (BV.zext w' i) + NatCaseEQ -> return x + NatCaseGT LeqProof -> + throwError $ "Attempted to zext " <> show w <> " bits to " <> show w' + + L.SExt + | IntType n <- mt + , IntConst w i <- x + , Just (Some w') <- someNat n + , Just LeqProof <- isPosNat w' + -> case testNatCases w w' of + NatCaseLT LeqProof -> return $ IntConst w' (BV.sext w w' i) + NatCaseEQ -> return x + NatCaseGT LeqProof -> + throwError $ "Attempted to sext " <> show w <> " bits to " <> show w' + + L.FpTrunc + | DoubleType <- mt + , DoubleConst d <- x + -> return $ DoubleConst d + + | FloatType <- mt + , DoubleConst d <- x + -> return $ FloatConst (realToFrac d) + + | FloatType <- mt + , FloatConst f <- x + -> return $ FloatConst f + + L.FpExt + | DoubleType <- mt + , DoubleConst d <- x + -> return $ DoubleConst d + + | DoubleType <- mt + , FloatConst f <- x + -> return $ DoubleConst (realToFrac f) + + | FloatType <- mt + , FloatConst f <- x + -> return $ FloatConst f + + L.IntToPtr -> return x + L.PtrToInt -> return x + + _ -> badExp "unexpected conversion operation" + + where badExp msg = throwError $ unlines [msg, show expr] + + +castToInt :: + MonadError String m => + L.ConstExpr {- ^ original expression to evaluate -} -> + EndianForm -> + Natural -> + MemType -> + LLVMConst -> + m Integer +castToInt _expr _endian _w (IntType w) x = asInt w x +castToInt expr endian w (VecType n tp) x + | (m,0) <- w `divMod` n = + do xs <- asVectorOf n (castToInt expr endian m tp) x + let indices = case endian of + LittleEndian -> [0 .. n-1] + BigEndian -> reverse [0 .. n-1] + let pieces = [ v `shiftL` (fromIntegral (i * m)) + | i <- indices + | v <- xs + ] + return (foldr (.|.) 0 pieces) + +castToInt expr _ _ _ _ = + throwError $ unlines ["Cannot cast expression to integer type", show expr] + +castFromInt :: + MonadError String m => + EndianForm -> + Integer -> + Natural -> + MemType -> + m LLVMConst +castFromInt _ xint w (IntType w') + | w == w' + , Some wsz <- mkNatRepr w + , Just LeqProof <- isPosNat wsz + = return $ IntConst wsz (BV.mkBV wsz xint) + +castFromInt endian xint w (VecType n tp) + | (m,0) <- w `divMod` n = + do let mask = (1 `shiftL` fromIntegral m) - 1 + let indices = case endian of + LittleEndian -> [0 .. n-1] + BigEndian -> reverse [0 .. n-1] + let pieces = [ mask .&. (xint `shiftR` fromIntegral (i * m)) + | i <- indices + ] + VectorConst tp <$> mapM (\x -> castFromInt endian x m tp) pieces + +castFromInt _ _ _ tp = + throwError $ unlines ["Cant cast integer to type", show tp] + +-- | Evaluate a bitcast +evalBitCast :: + (?lc :: TypeContext, MonadError String m) => + L.ConstExpr {- ^ original expression to evaluate -} -> + MemType {- ^ input expressio type -} -> + LLVMConst {- ^ input expression -} -> + MemType {- ^ desired output type -} -> + m LLVMConst + +-- cast zero constants to relabeled zero constants +evalBitCast _ _ (ZeroConst _) tgtT = return (ZeroConst tgtT) + +-- pointer casts always succeed +evalBitCast _ (PtrType _) expr (PtrType _) = return expr +evalBitCast _ (PtrType _) expr PtrOpaqueType = return expr +evalBitCast _ PtrOpaqueType expr (PtrType _) = return expr +evalBitCast _ PtrOpaqueType expr PtrOpaqueType = return expr + +-- casts between vectors of the same length can just be done pointwise +evalBitCast expr (VecType n srcT) (VectorConst _ xs) (VecType n' tgtT) + | n == n' = VectorConst tgtT <$> traverse (\x -> evalBitCast expr srcT x tgtT) xs + +-- otherwise, cast via an intermediate integer type +evalBitCast expr xty x toty + | Just w1 <- memTypeBitwidth xty + , Just w2 <- memTypeBitwidth toty + , w1 == w2 + = do let endian = ?lc ^. to llvmDataLayout.intLayout + xint <- castToInt expr endian w1 xty x + castFromInt endian xint w1 toty + +evalBitCast expr _ _ _ = + throwError $ unlines ["illegal constant bitcast", show expr] + + +asVectorOf :: + MonadError String m => + Natural -> + (LLVMConst -> m a) -> + (LLVMConst -> m [a]) +asVectorOf n f (ZeroConst (VecType m mt)) + | n == m + = do x <- f (ZeroConst mt) + return (replicate (fromIntegral n) x) + +asVectorOf n f (VectorConst _ xs) + | n == fromIntegral (length xs) + = traverse f xs + +asVectorOf n _ _ + = throwError ("Expected vector constant value of length: " ++ show n) + +-- | Type representing integer-like things. These are either actual +-- integer constants, or constant offsets from global symbols. +data ArithInt where + ArithInt :: Integer -> ArithInt + ArithPtr :: L.Symbol -> Integer -> ArithInt + +-- | A constant value to which arithmetic operation can be applied. +-- These are integers, pointers, floats and doubles. +data Arith where + ArithI :: ArithInt -> Arith + ArithF :: Float -> Arith + ArithD :: Double -> Arith + +asArithInt :: + (MonadError String m, HasPtrWidth wptr) => + Natural {- ^ expected integer width -} -> + LLVMConst {- ^ constant value -} -> + m ArithInt +asArithInt n (ZeroConst (IntType m)) + | n == m + = return (ArithInt 0) +asArithInt n (IntConst w x) + | n == natValue w + = return (ArithInt (BV.asUnsigned x)) +asArithInt n (SymbolConst sym off) + | n == natValue ?ptrWidth + = return (ArithPtr sym off) +asArithInt _ _ + = throwError "Expected integer value" + +asArith :: + (MonadError String m, HasPtrWidth wptr) => + MemType {- ^ expected type -} -> + LLVMConst {- ^ constant value -} -> + m Arith +asArith (IntType n) x = ArithI <$> asArithInt n x +asArith FloatType x = ArithF <$> asFloat x +asArith DoubleType x = ArithD <$> asDouble x +asArith _ _ = throwError "Expected arithmetic type" + +asInt :: + MonadError String m => + Natural {- ^ expected integer width -} -> + LLVMConst {- ^ constant value -} -> + m Integer +asInt n (ZeroConst (IntType m)) + | n == m + = return 0 +asInt n (IntConst w x) + | n == natValue w + = return (BV.asUnsigned x) +asInt n _ + = throwError ("Expected integer constant of size " ++ show n) + +asBV :: + MonadError String m => + NatRepr w {- ^ expected integer width -} -> + LLVMConst {- ^ constant value -} -> + m (BV.BV w) +asBV w (ZeroConst (IntType m)) + | natValue w == m + = return (BV.zero w) +asBV w (IntConst w' x) + | Just Refl <- w `testEquality` w' + = return x +asBV w _ + = throwError ("Expected integer constant of size " ++ show w) + +asFloat :: + MonadError String m => + LLVMConst {- ^ constant value -} -> + m Float +asFloat (ZeroConst FloatType) = return 0 +asFloat (FloatConst x) = return x +asFloat _ = throwError "Expected floating point constant" + +asDouble :: + MonadError String m => + LLVMConst {- ^ constant value -} -> + m Double +asDouble (ZeroConst DoubleType) = return 0 +asDouble (DoubleConst x) = return x +asDouble _ = throwError "Expected double constant" + + +-- | Compute the value of a constant expression. Fails if +-- the expression does not actually represent a constant value. +transConstantExpr :: forall m wptr. + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + L.ConstExpr -> + m LLVMConst +transConstantExpr expr = case expr of + L.ConstGEP inbounds _inrange baseTy base exps -> -- TODO? pay attention to the inrange flag + do gep <- translateGEP inbounds baseTy base exps + gep' <- traverse transConstant gep + snd <$> evalConstGEP gep' + + L.ConstSelect b x y -> + do b' <- transConstant b + x' <- transConstant x + y' <- transConstant y + case b' of + IntConst w v + | v /= BV.zero w -> return x' + | otherwise -> return y' + _ -> badExp "Expected boolean value in constant select" + + L.ConstBlockAddr _ _ -> + badExp "constant block addresses not supported" + + L.ConstFCmp op a b -> + do mt <- liftMemType (L.typedType a) + case mt of + VecType n FloatType -> + do a' <- asVectorOf n asFloat =<< transConstant a + b' <- asVectorOf n asFloat =<< transConstant b + return $ VectorConst (IntType 1) $ zipWith (evalFcmp op) a' b' + VecType n DoubleType -> + do a' <- asVectorOf n asDouble =<< transConstant a + b' <- asVectorOf n asDouble =<< transConstant b + return $ VectorConst (IntType 1) $ zipWith (evalFcmp op) a' b' + FloatType -> + do a' <- asFloat =<< transConstant a + b' <- asFloat =<< transConstant b + return $ evalFcmp op a' b' + DoubleType -> + do a' <- asDouble =<< transConstant a + b' <- asDouble =<< transConstant b + return $ evalFcmp op a' b' + _ -> badExp "Expected floating point arguments" + + L.ConstICmp op a b -> + do mt <- liftMemType (L.typedType a) + case mt of + VecType n (IntType m) + | Some w <- mkNatRepr m + , Just LeqProof <- isPosNat w + -> do a' <- asVectorOf n (asBV w) =<< transConstant a + b' <- asVectorOf n (asBV w) =<< transConstant b + return $ VectorConst (IntType 1) $ zipWith (evalIcmp op w) a' b' + IntType m + | Some w <- mkNatRepr m + , Just LeqProof <- isPosNat w + -> do a' <- asBV w =<< transConstant a + b' <- asBV w =<< transConstant b + return $ evalIcmp op w a' b' + _ -> badExp "Expected integer arguments" + + L.ConstArith op (L.Typed tp a) b -> + do mt <- liftMemType tp + case mt of + VecType n tp' -> + do a' <- asVectorOf n (asArith tp') =<< transConstant' mt a + b' <- asVectorOf n (asArith tp') =<< transConstant' mt b + VectorConst tp' <$> zipWithM (evalArith op tp') a' b' + tp' -> + do a' <- asArith tp' =<< transConstant' mt a + b' <- asArith tp' =<< transConstant' mt b + evalArith op tp' a' b' + + L.ConstUnaryArith op (L.Typed tp a) -> + do mt <- liftMemType tp + case mt of + VecType n tp' -> + do a' <- asVectorOf n (asArith tp') =<< transConstant' mt a + VectorConst tp' <$> traverse (evalUnaryArith op tp') a' + tp' -> + do a' <- asArith tp' =<< transConstant' mt a + evalUnaryArith op tp' a' + + L.ConstBit op (L.Typed tp a) b -> + do mt <- liftMemType tp + case mt of + VecType n (IntType m) + | Some w <- mkNatRepr m + , Just LeqProof <- isPosNat w + -> do a' <- asVectorOf n (asBV w) =<< transConstant' mt a + b' <- asVectorOf n (asBV w) =<< transConstant' mt b + VectorConst (IntType m) <$> zipWithM (evalBitwise op w) a' b' + IntType m + | Some w <- mkNatRepr m + , Just LeqProof <- isPosNat w + -> do a' <- asBV w =<< transConstant' mt a + b' <- asBV w =<< transConstant' mt b + evalBitwise op w a' b' + _ -> badExp "Expected integer arguments" + + L.ConstConv L.BitCast (L.Typed tp x) outty -> + do toty <- liftMemType outty + xty <- liftMemType tp + x' <- transConstant' xty x + evalBitCast expr xty x' toty + + L.ConstConv op x outty -> + do mt <- liftMemType outty + x' <- transConstant x + case mt of + VecType n mt' -> + do xs <- asVectorOf n return x' + VectorConst mt' <$> traverse (evalConv expr op mt') xs + + _ -> evalConv expr op mt x' + + where + badExp :: String -> m a + badExp msg = throwError $ unlines [msg, show expr] + +testBreakpointFunction :: String -> Bool +testBreakpointFunction = isPrefixOf "__breakpoint__" diff --git a/src/Lang/Crucible/LLVM/Translation/Expr.hs b/src/Lang/Crucible/LLVM/Translation/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Expr.hs @@ -0,0 +1,572 @@ + +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Expr +-- Description : Translation-time LLVM expressions +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +----------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.Translation.Expr + ( LLVMExpr(..) + , ScalarView(..) + , asScalar + , asVectorWithType + , asVector + + , pattern PointerExpr + , pattern BitvectorAsPointerExpr + , pointerAsBitvectorExpr + + , unpackOne + , unpackVec + , unpackArgs + , zeroExpand + , undefExpand + , explodeVector + + , constToLLVMVal + , transValue + , transTypedValue + , transTypeAndValue + , liftConstant + + , callIsNull + , callIntToBool + , callAlloca + , callPushFrame + , callPopFrame + , callPtrAddOffset + , callPtrSubtract + , callLoad + , callStore + ) where + +import Control.Lens hiding ((:>)) +import Control.Monad +import Control.Monad.Except +import qualified Data.ByteString as BS +import Data.Foldable (toList) +import qualified Data.List as List +--import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.String +import qualified Data.Vector as V +import Numeric.Natural +import GHC.Exts ( Proxy#, proxy# ) + +import qualified Data.BitVector.Sized as BV +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Context ( pattern (:>) ) +import Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Some +import Data.Text (Text) + +import qualified Text.LLVM.AST as L + +import qualified Lang.Crucible.CFG.Core as C +import Lang.Crucible.CFG.Expr +import Lang.Crucible.CFG.Generator +import Lang.Crucible.CFG.Extension () + +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.Translation.Constant +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.Syntax +import Lang.Crucible.Types + +import What4.InterpretedFloatingPoint (X86_80Val(..)) + +------------------------------------------------------------------------- +-- LLVMExpr +-- +-- As noted in "Lang.Crucible.LLVM.Translation.Types", this code uses +-- a polymorphic continuation-passing style to convert to +-- strongly-typed Crucible types from less-strongly-typed LLVM +-- types. As part of that, the LLVM architecture (notably the pointer +-- width) must be unified between the outer context and the +-- continuation; the 'proxy#' arguments here and below represent a +-- 'Proxy# arch' type that is used to maintain that architecture +-- definition and corresponding pointer width for the conversions. + +-- | An intermediate form of LLVM expressions that retains some structure +-- that would otherwise be more difficult to retain if we translated directly +-- into crucible expressions. +data LLVMExpr s (arch :: LLVMArch) where + BaseExpr :: TypeRepr tp -> Expr LLVM s tp -> LLVMExpr s arch + ZeroExpr :: MemType -> LLVMExpr s arch + UndefExpr :: MemType -> LLVMExpr s arch + VecExpr :: MemType -> Seq (LLVMExpr s arch) -> LLVMExpr s arch + StructExpr :: Seq (MemType, LLVMExpr s arch) -> LLVMExpr s arch + +instance Show (LLVMExpr s arch) where + show (BaseExpr ty x) = C.showF x ++ " : " ++ show ty + show (ZeroExpr mt) = "" + show (UndefExpr mt) = "" + show (VecExpr _mt xs) = "[" ++ List.intercalate ", " (map show (toList xs)) ++ "]" + show (StructExpr xs) = "{" ++ List.intercalate ", " (map f (toList xs)) ++ "}" + where f (_mt,x) = show x + + +data ScalarView s (arch :: LLVMArch) where + Scalar :: Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> ScalarView s arch + NotScalar :: ScalarView s arch + +-- | Examine an LLVM expression and return the corresponding +-- crucible expression, if it is a scalar. +asScalar :: (?lc :: TypeContext, HasPtrWidth (ArchWidth arch)) + => LLVMExpr s arch + -> ScalarView s arch +asScalar (BaseExpr tp xs) + = Scalar proxy# tp xs +asScalar (ZeroExpr llvmtp) + = let ?err = error + in zeroExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex +asScalar (UndefExpr llvmtp) + = let ?err = error + in undefExpand proxy# llvmtp $ \archProxy tpr ex -> Scalar archProxy tpr ex +asScalar _ = NotScalar + +-- | Turn the expression into an explicit vector. +asVectorWithType :: LLVMExpr s arch -> Maybe (MemType, Seq (LLVMExpr s arch)) +asVectorWithType v = + case v of + ZeroExpr (VecType n t) -> Just (t, Seq.replicate (fromIntegral n) (ZeroExpr t)) + UndefExpr (VecType n t) -> Just (t, Seq.replicate (fromIntegral n) (UndefExpr t)) + VecExpr t s -> Just (t, s) + _ -> Nothing + +asVector :: LLVMExpr s arch -> Maybe (Seq (LLVMExpr s arch)) +asVector = fmap snd . asVectorWithType + + +nullPointerExpr :: (HasPtrWidth w) => Expr LLVM s (LLVMPointerType w) +nullPointerExpr = PointerExpr PtrWidth (App (NatLit 0)) (App (BVLit PtrWidth (BV.zero PtrWidth))) + +pattern PointerExpr + :: (1 <= w) + => NatRepr w + -> Expr LLVM s NatType + -> Expr LLVM s (BVType w) + -> Expr LLVM s (LLVMPointerType w) +pattern PointerExpr w blk off = App (ExtensionApp (LLVM_PointerExpr w blk off)) + +pattern BitvectorAsPointerExpr + :: (1 <= w) + => NatRepr w + -> Expr LLVM s (BVType w) + -> Expr LLVM s (LLVMPointerType w) +pattern BitvectorAsPointerExpr w ex = PointerExpr w (App (NatLit 0)) ex + +pointerAsBitvectorExpr + :: (1 <= w) + => NatRepr w + -> Expr LLVM s (LLVMPointerType w) + -> LLVMGenerator s arch ret (Expr LLVM s (BVType w)) +pointerAsBitvectorExpr _ (BitvectorAsPointerExpr _ ex) = + return ex +pointerAsBitvectorExpr w ex = + do ex' <- forceEvaluation ex + let blk = App (ExtensionApp (LLVM_PointerBlock w ex')) + let off = App (ExtensionApp (LLVM_PointerOffset w ex')) + assertExpr (blk .== litExpr 0) + (litExpr "Expected bitvector, but found pointer") + return off + + + +-- | Given a list of LLVMExpressions, "unpack" them into an assignment +-- of crucible expressions. +unpackArgs :: forall s a arch + . (?err :: String -> a + ,HasPtrWidth (ArchWidth arch) + ) + => [LLVMExpr s arch] + -> (forall ctx. Proxy# arch -> CtxRepr ctx -> Ctx.Assignment (Expr LLVM s) ctx -> a) + -> a +unpackArgs = go Ctx.Empty Ctx.Empty + where go :: CtxRepr ctx + -> Ctx.Assignment (Expr LLVM s) ctx + -> [LLVMExpr s arch] + -> (forall ctx'. Proxy# arch -> CtxRepr ctx' -> Ctx.Assignment (Expr LLVM s) ctx' -> a) + -> a + go ctx asgn [] k = k proxy# ctx asgn + go ctx asgn (v:vs) k = unpackOne v (\_ tyr ex -> go (ctx :> tyr) (asgn :> ex) vs k) + +unpackOne + :: (?err :: String -> a, HasPtrWidth (ArchWidth arch)) + => LLVMExpr s arch + -> (forall tpr. Proxy# arch -> TypeRepr tpr -> Expr LLVM s tpr -> a) + -> a +unpackOne (BaseExpr tyr ex) k = k proxy# tyr ex +unpackOne (UndefExpr tp) k = undefExpand proxy# tp k +unpackOne (ZeroExpr tp) k = zeroExpand proxy# tp k +unpackOne (StructExpr vs) k = + unpackArgs (map snd $ toList vs) $ \archProxy struct_ctx struct_asgn -> + k archProxy (StructRepr struct_ctx) (mkStruct struct_ctx struct_asgn) +unpackOne (VecExpr tp vs) k = + llvmTypeAsRepr tp $ \tpr -> unpackVec proxy# tpr (toList vs) $ k proxy# (VectorRepr tpr) + +unpackVec :: forall tpr s arch a + . ( ?err :: String -> a + , HasPtrWidth (ArchWidth arch) + ) + => Proxy# arch + -> TypeRepr tpr + -> [LLVMExpr s arch] + -> (Expr LLVM s (VectorType tpr) -> a) + -> a +unpackVec _archProxy tpr = go [] . reverse + where go :: [Expr LLVM s tpr] -> [LLVMExpr s arch] -> (Expr LLVM s (VectorType tpr) -> a) -> a + go vs [] k = k (vectorLit tpr $ V.fromList vs) + go vs (x:xs) k = unpackOne x $ \_archProxy' tpr' v -> + case testEquality tpr tpr' of + Just Refl -> go (v:vs) xs k + Nothing -> ?err $ unwords ["type mismatch in array value", show tpr, show tpr'] + +zeroExpand :: (?err :: String -> a, HasPtrWidth (ArchWidth arch)) + => Proxy# arch + -> MemType + -> (forall tp. Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> a) + -> a +zeroExpand _proxyArch (IntType w) k = + case mkNatRepr w of + Some w' | Just LeqProof <- isPosNat w' -> + k proxy# (LLVMPointerRepr w') $ + BitvectorAsPointerExpr w' $ + App $ BVLit w' (BV.zero w') + + _ -> ?err $ unwords ["illegal integer size", show w] + +zeroExpand _proxyArch (StructType si) k = + unpackArgs (map ZeroExpr tps) $ \archProxy ctx asgn -> k archProxy (StructRepr ctx) (mkStruct ctx asgn) + where tps = map fiType $ toList $ siFields si +zeroExpand proxyArch (ArrayType n tp) k = + llvmTypeAsRepr tp $ \tpr -> unpackVec proxyArch tpr (replicate (fromIntegral n) (ZeroExpr tp)) $ k proxyArch (VectorRepr tpr) +zeroExpand proxyArch (VecType n tp) k = + llvmTypeAsRepr tp $ \tpr -> unpackVec proxyArch tpr (replicate (fromIntegral n) (ZeroExpr tp)) $ k proxyArch (VectorRepr tpr) +zeroExpand proxyArch (PtrType _tp) k = k proxyArch PtrRepr nullPointerExpr +zeroExpand proxyArch PtrOpaqueType k = k proxyArch PtrRepr nullPointerExpr +zeroExpand proxyArch FloatType k = k proxyArch (FloatRepr SingleFloatRepr) (App (FloatLit 0)) +zeroExpand proxyArch DoubleType k = k proxyArch (FloatRepr DoubleFloatRepr) (App (DoubleLit 0)) +zeroExpand _prxyArch X86_FP80Type _ = ?err "Cannot zero expand x86_fp80 values" +zeroExpand _prxyArch MetadataType _ = ?err "Cannot zero expand metadata" + +undefExpand :: ( ?err :: String -> a + , HasPtrWidth (ArchWidth arch) + ) + => Proxy# arch + -> MemType + -> (forall tp. Proxy# arch -> TypeRepr tp -> Expr LLVM s tp -> a) + -> a +undefExpand _archProxy (IntType w) k = + case mkNatRepr w of + Some w' | Just LeqProof <- isPosNat w' -> + k proxy# (LLVMPointerRepr w') $ + BitvectorAsPointerExpr w' $ + App $ BVUndef w' + + _ -> ?err $ unwords ["illegal integer size", show w] +undefExpand _archProxy (PtrType _tp) k = + k proxy# PtrRepr $ BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth +undefExpand _archProxy PtrOpaqueType k = + k proxy# PtrRepr $ BitvectorAsPointerExpr PtrWidth $ App $ BVUndef PtrWidth +undefExpand _archProxy (StructType si) k = + unpackArgs (map UndefExpr tps) $ \archProxy ctx asgn -> k archProxy (StructRepr ctx) (mkStruct ctx asgn) + where tps = map fiType $ toList $ siFields si +undefExpand archProxy (ArrayType n tp) k = + llvmTypeAsRepr tp $ \tpr -> unpackVec archProxy tpr (replicate (fromIntegral n) (UndefExpr tp)) $ k proxy# (VectorRepr tpr) +undefExpand archProxy (VecType n tp) k = + llvmTypeAsRepr tp $ \tpr -> unpackVec archProxy tpr (replicate (fromIntegral n) (UndefExpr tp)) $ k proxy# (VectorRepr tpr) +undefExpand _archProxy FloatType k = + k proxy# (FloatRepr SingleFloatRepr) (App (FloatUndef SingleFloatRepr)) +undefExpand _archProxy DoubleType k = + k proxy# (FloatRepr DoubleFloatRepr) (App (FloatUndef DoubleFloatRepr)) +undefExpand _archProxy X86_FP80Type k = + k proxy# (FloatRepr X86_80FloatRepr) (App (FloatUndef X86_80FloatRepr)) +undefExpand _archPrxy tp _ = ?err $ unwords ["cannot undef expand type:", show tp] + + +explodeVector :: Natural -> LLVMExpr s arch -> Maybe (Seq (LLVMExpr s arch)) +explodeVector n (UndefExpr (VecType n' tp)) | n == n' = return (Seq.replicate (fromIntegral n) (UndefExpr tp)) +explodeVector n (ZeroExpr (VecType n' tp)) | n == n' = return (Seq.replicate (fromIntegral n) (ZeroExpr tp)) +explodeVector n (VecExpr _tp xs) + | n == fromIntegral (length xs) = return xs +explodeVector n (BaseExpr (VectorRepr tpr) v) = + let xs = [ BaseExpr tpr (app $ VectorGetEntry tpr v (litExpr i)) | i <- [0..n-1] ] + in return (Seq.fromList xs) +explodeVector _ _ = Nothing + + +--------------------------------------------------------------------------- +-- Translations + +liftConstant :: + HasPtrWidth (ArchWidth arch) => + LLVMConst -> + LLVMGenerator s arch ret (LLVMExpr s arch) +liftConstant c = case c of + ZeroConst mt -> + return $ ZeroExpr mt + UndefConst mt -> + return $ UndefExpr mt + IntConst w i -> + return $ BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w (App (BVLit w i))) + FloatConst f -> + return $ BaseExpr (FloatRepr SingleFloatRepr) (App (FloatLit f)) + DoubleConst d -> + return $ BaseExpr (FloatRepr DoubleFloatRepr) (App (DoubleLit d)) + LongDoubleConst (L.FP80_LongDouble ex man) -> + return $ BaseExpr (FloatRepr X86_80FloatRepr) (App (X86_80Lit (X86_80Val ex man))) + StringConst bs -> + -- TODO? Should we have a StringExpr? It seems like this case doesn't + -- actually ever arise... + do vs <- mapM (\b -> liftConstant (IntConst knownNat (BV.word8 b))) (BS.unpack bs) + return (VecExpr i8 $ Seq.fromList vs) + ArrayConst mt vs -> + do vs' <- mapM (\c' -> liftConstant c') vs + return (VecExpr mt $ Seq.fromList vs') + VectorConst mt vs -> + do vs' <- mapM (\c' -> liftConstant c') vs + return (VecExpr mt $ Seq.fromList vs') + StructConst si vs -> + do vs' <- mapM (\c' -> liftConstant c') vs + let ts = map fiType $ V.toList (siFields si) + unless (length vs' == length ts) + (fail "Type mismatch in structure constant") + return (StructExpr (Seq.fromList (zip ts vs'))) + SymbolConst sym 0 -> + do memVar <- getMemVar + base <- extensionStmt (LLVM_ResolveGlobal ?ptrWidth memVar (GlobalSymbol sym)) + return (BaseExpr PtrRepr base) + SymbolConst sym off -> + do memVar <- getMemVar + base <- extensionStmt (LLVM_ResolveGlobal ?ptrWidth memVar (GlobalSymbol sym)) + let off' = app $ BVLit ?ptrWidth (BV.mkBV ?ptrWidth off) + ptr <- extensionStmt (LLVM_PtrAddOffset ?ptrWidth memVar base off') + return (BaseExpr PtrRepr ptr) + +transTypeAndValue :: + L.Typed L.Value -> + LLVMGenerator s arch ret (MemType, LLVMExpr s arch) +transTypeAndValue v = + do let err msg = + malformedLLVMModule + "Invalid value type" + [ fromString msg ] + tp <- either err return $ liftMemType $ L.typedType v + (\ex -> (tp, ex)) <$> transValue tp (L.typedValue v) + +transTypedValue :: + L.Typed L.Value -> + LLVMGenerator s arch ret (LLVMExpr s arch) +transTypedValue v = snd <$> transTypeAndValue v + +-- | Translate an LLVM Value into an expression. +transValue :: forall s arch ret. + MemType + -> L.Value + -> LLVMGenerator s arch ret (LLVMExpr s arch) + +transValue ty L.ValUndef = + return $ UndefExpr ty + +transValue ty L.ValZeroInit = + return $ ZeroExpr ty + +transValue ty@(PtrType _) L.ValNull = + return $ ZeroExpr ty +transValue ty@PtrOpaqueType L.ValNull = + return $ ZeroExpr ty + +transValue ty@(PtrType _) (L.ValInteger 0) = + return $ ZeroExpr ty +transValue ty@PtrOpaqueType (L.ValInteger 0) = + return $ ZeroExpr ty + +transValue ty@(PtrType _) v@(L.ValInteger _) = + reportError $ fromString $ unwords ["Attempted to use integer ", show v, " as pointer: ", show ty] +transValue ty@PtrOpaqueType v@(L.ValInteger _) = + reportError $ fromString $ unwords ["Attempted to use integer ", show v, " as pointer: ", show ty] + +transValue ty@(IntType _) L.ValNull = + return $ ZeroExpr ty + +transValue _ (L.ValString str) = do + let eight = knownNat :: NatRepr 8 + let bv8 = LLVMPointerRepr eight + let chars = V.fromList $ map (BitvectorAsPointerExpr eight . App . BVLit eight . BV.mkBV eight . toInteger . fromEnum) $ str + return $ BaseExpr (VectorRepr bv8) (App $ VectorLit bv8 $ chars) + +transValue _ (L.ValIdent i) = do + m <- use identMap + case Map.lookup i m of + Nothing -> do + reportError $ fromString $ "Could not find identifier " ++ show i ++ "." + Just (Left (Some r)) -> do + e <- readReg r + return $ BaseExpr (typeOfReg r) e + Just (Right (Some a)) -> do + return $ BaseExpr (typeOfAtom a) (AtomExpr a) + +transValue (IntType n) (L.ValInteger i) = + runExceptT (intConst n i) >>= \case + Left err -> fail err + Right c -> liftConstant c + +transValue (IntType 1) (L.ValBool b) = + liftConstant (boolConst b) + +transValue FloatType (L.ValFloat f) = + liftConstant (FloatConst f) + +transValue DoubleType (L.ValDouble d) = + liftConstant (DoubleConst d) + +transValue (StructType _) (L.ValStruct vs) = do + vs' <- mapM (\v -> transTypeAndValue v) vs + return (StructExpr $ Seq.fromList $ vs') + +transValue (StructType _) (L.ValPackedStruct vs) = do + vs' <- mapM (\v -> transTypeAndValue v) vs + return (StructExpr $ Seq.fromList $ vs') + +transValue (ArrayType _ tp) (L.ValArray _ vs) = do + vs' <- mapM (\v -> transValue tp v) vs + return (VecExpr tp $ Seq.fromList vs') + +transValue (VecType _ tp) (L.ValVector _ vs) = do + vs' <- mapM (\v -> transValue tp v) vs + return (VecExpr tp $ Seq.fromList vs') + +transValue _ (L.ValSymbol symbol) = do + liftConstant (SymbolConst symbol 0) + +transValue _ (L.ValConstExpr cexp) = + do res <- runExceptT (transConstantExpr cexp) + case res of + Left err -> reportError $ fromString $ unlines ["Error translating constant", err] + Right cv -> liftConstant cv + +transValue ty v = + reportError $ fromString $ unwords ["unsupported LLVM value:", show v, "of type", show ty] + + +callIsNull + :: (1 <= w) + => NatRepr w + -> Expr LLVM s (LLVMPointerType w) + -> LLVMGenerator s arch ret (Expr LLVM s BoolType) +callIsNull w ex = App . Not <$> callIntToBool w ex + +callIntToBool + :: (1 <= w) + => NatRepr w + -> Expr LLVM s (LLVMPointerType w) + -> LLVMGenerator s arch ret (Expr LLVM s BoolType) +callIntToBool w (BitvectorAsPointerExpr _ bv) = + case bv of + App (BVLit _ i) -> if i == BV.zero w then return false else return true + _ -> return (App (BVNonzero w bv)) +callIntToBool w ex = + do ex' <- forceEvaluation ex + let blk = App (ExtensionApp (LLVM_PointerBlock w ex')) + let off = App (ExtensionApp (LLVM_PointerOffset w ex')) + return (blk ./= litExpr 0 .|| (App (BVNonzero w off))) + +callAlloca + :: wptr ~ ArchWidth arch + => Expr LLVM s (BVType wptr) + -> Alignment + -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) +callAlloca sz alignment = do + memVar <- getMemVar + loc <- show <$> getPosition + extensionStmt (LLVM_Alloca ?ptrWidth memVar sz alignment loc) + +callPushFrame :: Text -> LLVMGenerator s arch ret () +callPushFrame nm = do + memVar <- getMemVar + void $ extensionStmt (LLVM_PushFrame nm memVar) + +callPopFrame :: LLVMGenerator s arch ret () +callPopFrame = do + memVar <- getMemVar + void $ extensionStmt (LLVM_PopFrame memVar) + +callPtrAddOffset :: + wptr ~ ArchWidth arch + => Expr LLVM s (LLVMPointerType wptr) + -> Expr LLVM s (BVType wptr) + -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) +callPtrAddOffset base off = do + memVar <- getMemVar + extensionStmt (LLVM_PtrAddOffset ?ptrWidth memVar base off) + +callPtrSubtract :: + wptr ~ ArchWidth arch + => Expr LLVM s (LLVMPointerType wptr) + -> Expr LLVM s (LLVMPointerType wptr) + -> LLVMGenerator s arch ret (Expr LLVM s (BVType wptr)) +callPtrSubtract x y = do + memVar <- getMemVar + extensionStmt (LLVM_PtrSubtract ?ptrWidth memVar x y) + +callLoad :: MemType + -> TypeRepr tp + -> LLVMExpr s arch + -> Alignment + -> LLVMGenerator s arch ret (LLVMExpr s arch) +callLoad typ expectTy (asScalar -> Scalar _ PtrRepr ptr) align = + do memVar <- getMemVar + typ' <- toStorableType typ + v <- extensionStmt (LLVM_Load memVar ptr expectTy typ' align) + return (BaseExpr expectTy v) +callLoad _ _ _ _ = + fail $ unwords ["Unexpected argument type in callLoad"] + +callStore :: MemType + -> LLVMExpr s arch + -> LLVMExpr s arch + -> Alignment + -> LLVMGenerator s arch ret () +callStore typ (asScalar -> Scalar _ PtrRepr ptr) (ZeroExpr _mt) _align = + do memVar <- getMemVar + typ' <- toStorableType typ + void $ extensionStmt (LLVM_MemClear memVar ptr (storageTypeSize typ')) + +callStore typ (asScalar -> Scalar _ PtrRepr ptr) v align = + do let ?err = fail + unpackOne v $ \_ vtpr vexpr -> do + memVar <- getMemVar + typ' <- toStorableType typ + void $ extensionStmt (LLVM_Store memVar ptr vtpr typ' align vexpr) + +callStore _ _ _ _ = + fail $ unwords ["Unexpected argument type in callStore"] diff --git a/src/Lang/Crucible/LLVM/Translation/Instruction.hs b/src/Lang/Crucible/LLVM/Translation/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Instruction.hs @@ -0,0 +1,2109 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Instruction +-- Description : Translation of LLVM instructions +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- This module represents the workhorse of the LLVM translation. It +-- is responsible for interpreting the LLVM instruction set into +-- corresponding crucible statements. +----------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Lang.Crucible.LLVM.Translation.Instruction + ( instrResultType + , generateInstr + , definePhiBlock + , assignLLVMReg + , callOrdinaryFunction + ) where + +import Prelude hiding (exp, pred) + +import Control.Lens hiding (op, (:>) ) +import Control.Monad (MonadPlus(..), forM, unless) +import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.State.Strict (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Maybe +import Data.Foldable (for_, toList) +import Data.Functor (void) +import Data.Int +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.String +import qualified Data.Text as Text +import qualified Data.Vector as V +import Numeric.Natural +import Prettyprinter (pretty) +import GHC.Exts ( Proxy#, proxy# ) + +import qualified Text.LLVM.AST as L + +import qualified Data.BitVector.Sized as BV +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Some + +import What4.Utils.StringLiteral + +import Lang.Crucible.CFG.Expr +import Lang.Crucible.CFG.Generator + +import qualified Lang.Crucible.LLVM.Bytes as G +import Lang.Crucible.LLVM.DataLayout +import qualified Lang.Crucible.LLVM.Errors.Poison as Poison +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.MemType +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.Translation.Constant +import Lang.Crucible.LLVM.Translation.Expr +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Translation.Options +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext +import Lang.Crucible.Syntax hiding (IsExpr) +import Lang.Crucible.Types + +-------------------------------------------------------------------------------- +-- Assertions + +-- | Add a bunch of side conditions to a value. +-- +-- Allows for effectful computation of the predicates and expressions. +sideConditionsA :: forall f ty s. Applicative f + => GlobalVar Mem + -> TypeRepr ty + -> Expr LLVM s ty + -- ^ Expression with side-condition + -> [( Bool + , f (Expr LLVM s BoolType) + , UB.UndefinedBehavior (Expr LLVM s) + )] + -- ^ Conditions to (conditionally) assert + -> f (Expr LLVM s ty) +sideConditionsA mvar tyRepr expr conds = + let middle :: Applicative g => (a, g b, c) -> g (a, b, c) + middle (a, fb, c) = (,,) <$> pure a <*> fb <*> pure c + + fmapMaybe :: Functor g => g [a] -> (a -> Maybe b) -> g [b] + fmapMaybe gs h = fmap (mapMaybe h) gs + + conds' :: f [LLVMSideCondition (Expr LLVM s)] + conds' = fmapMaybe (traverse middle conds) $ \(b, pred, classifier) -> + (if b then Just else const Nothing) $ + LLVMSideCondition pred classifier + in flip fmap conds' $ + \case + [] -> expr -- No assertions left, nothing to do. + (x:xs) -> App $ ExtensionApp $ LLVM_SideConditions mvar tyRepr (x :| xs) expr + +-- | Assert that evaluation doesn't result in a poison value +poisonSideCondition :: GlobalVar Mem + -> TypeRepr ty + -> Poison.Poison (Expr LLVM s) + -> Expr LLVM s ty + -- ^ Expression with side-condition + -> Expr LLVM s BoolType + -- ^ Condition to assert + -> Expr LLVM s ty +poisonSideCondition mvar tyRepr poison expr cond = + runIdentity $ sideConditionsA mvar tyRepr expr [(True, pure cond, UB.PoisonValueCreated poison)] + +-------------------------------------------------------------------------------- +-- Translation + +-- | Get the return type of an LLVM instruction +-- See . +instrResultType :: + (?lc :: TypeContext, MonadError String m, HasPtrWidth wptr) => + L.Instr -> + m MemType +instrResultType instr = + case instr of + L.Arith _ x _ -> liftMemType (L.typedType x) + L.UnaryArith _ x -> liftMemType (L.typedType x) + L.Bit _ x _ -> liftMemType (L.typedType x) + L.Conv _ _ ty -> liftMemType ty + L.Call _ (L.FunTy ty _ _) _ _ -> liftMemType ty + L.Call _ ty _ _ -> throwError $ unwords ["unexpected non-function type in call:", show ty] + L.Invoke (L.FunTy ty _ _) _ _ _ _ -> liftMemType ty + L.Invoke ty _ _ _ _ -> throwError $ unwords ["unexpected non-function type in invoke:", show ty] + L.CallBr (L.FunTy ty _ _) _ _ _ _ -> liftMemType ty + L.CallBr ty _ _ _ _ -> throwError $ unwords ["unexpected non-function type in callbr:", show ty] + L.Alloca ty _ _ -> liftMemType (L.PtrTo ty) + L.Load tp _ _ _ -> liftMemType tp + L.ICmp _op tv _ -> do + inpType <- liftMemType (L.typedType tv) + case inpType of + VecType len _ -> return (VecType len (IntType 1)) + _ -> return (IntType 1) + L.FCmp _op tv _ -> do + inpType <- liftMemType (L.typedType tv) + case inpType of + VecType len _ -> return (VecType len (IntType 1)) + _ -> return (IntType 1) + L.Phi tp _ -> liftMemType tp + + L.GEP inbounds baseTy basePtr elts -> + do gepRes <- runExceptT (translateGEP inbounds baseTy basePtr elts) + case gepRes of + Left err -> throwError err + Right (GEPResult lanes tp _gep) -> + let n = natValue lanes in + if n == 1 then + return (PtrType (MemType tp)) + else + return (VecType n (PtrType (MemType tp))) + + L.Select _ x _ -> liftMemType (L.typedType x) + + L.ExtractValue x idxes -> liftMemType (L.typedType x) >>= go idxes + where go [] tp = return tp + go (i:is) (ArrayType n tp') + | i < fromIntegral n = go is tp' + | otherwise = throwError $ unwords ["invalid index into array type", showInstr instr] + go (i:is) (StructType si) = + case siFields si V.!? (fromIntegral i) of + Just fi -> go is (fiType fi) + Nothing -> throwError $ unwords ["invalid index into struct type", showInstr instr] + go _ _ = throwError $ unwords ["invalid type in extract value instruction", showInstr instr] + + L.InsertValue x _ _ -> liftMemType (L.typedType x) + + L.ExtractElt x _ -> + do tp <- liftMemType (L.typedType x) + case tp of + VecType _n tp' -> return tp' + _ -> throwError $ unwords ["extract element of non-vector type", showInstr instr] + + L.InsertElt x _ _ -> liftMemType (L.typedType x) + + L.ShuffleVector x _ i -> + do xtp <- liftMemType (L.typedType x) + itp <- liftMemType (L.typedType i) + case (xtp, itp) of + (VecType _n ty, VecType m _) -> return (VecType m ty) + _ -> throwError $ unwords ["invalid shufflevector:", showInstr instr] + + L.LandingPad x _ _ _ -> liftMemType x + + -- LLVM Language Reference: "The original value at the location is returned." + L.AtomicRW _ _ _ v _ _ -> liftMemType (L.typedType v) + + L.CmpXchg _weak _volatile _ptr _old new _ _ _ -> + do let dl = llvmDataLayout ?lc + tp <- liftMemType (L.typedType new) + return (StructType (mkStructInfo dl False [tp, i1])) + + L.Freeze x -> liftMemType (L.typedType x) + + _ -> throwError $ unwords ["instrResultType, unsupported instruction:", showInstr instr] + +-- | Given an LLVM expression of vector type, select out the ith element. +extractElt + :: forall s arch ret. + L.Instr + -> MemType -- ^ type contained in the vector + -> Integer -- ^ size of the vector + -> LLVMExpr s arch -- ^ vector expression + -> LLVMExpr s arch -- ^ index expression + -> LLVMGenerator s arch ret (LLVMExpr s arch) +extractElt _instr ty _n (UndefExpr _) _i = + return $ UndefExpr ty +extractElt _instr ty _n (ZeroExpr _) _i = + return $ ZeroExpr ty +extractElt _ ty _ _ (UndefExpr _) = + return $ UndefExpr ty +extractElt instr ty n v (ZeroExpr zty) = + let ?err = fail in + zeroExpand (proxy# :: Proxy# arch) zty $ \_archProxy tyr ex -> extractElt instr ty n v (BaseExpr tyr ex) +extractElt instr _ n (VecExpr _ vs) i + | Scalar _archProxy (LLVMPointerRepr _) (BitvectorAsPointerExpr _ x) <- asScalar i + , App (BVLit _ x') <- x + = constantExtract (BV.asUnsigned x') + + where + constantExtract :: Integer -> LLVMGenerator s arch ret (LLVMExpr s arch) + constantExtract idx = + if (fromInteger idx < Seq.length vs) && (fromInteger idx < n) + then return $ Seq.index vs (fromInteger idx) + else fail (unlines ["invalid extractelement instruction (index out of bounds)", showInstr instr]) + +extractElt instr ty n (VecExpr _ vs) i = do + let ?err = fail + llvmTypeAsRepr ty $ \tyr -> unpackVec (proxy# :: Proxy# arch) tyr (toList vs) $ + \ex -> extractElt instr ty n (BaseExpr (VectorRepr tyr) ex) i +extractElt instr _ n (BaseExpr (VectorRepr tyr) v) i = + do mvar <- getMemVar + idx <- case asScalar i of + Scalar _archProxy (LLVMPointerRepr w) x -> + do bv <- pointerAsBitvectorExpr w x + -- The value is poisoned if the index is out of bounds. + let poison = Poison.ExtractElementIndex bv + return $ poisonSideCondition + mvar + NatRepr + poison + -- returned expression + (App (BvToNat w bv)) + -- assertion condition + (App (BVUlt w bv (App (BVLit w (BV.mkBV w n))))) + _ -> + fail (unlines ["invalid extractelement instruction", showInstr instr]) + return $ BaseExpr tyr (App (VectorGetEntry tyr v idx)) + +extractElt instr _ _ _ _ = fail (unlines ["invalid extractelement instruction", showInstr instr]) + + +-- | Given an LLVM expression of vector type, insert a new element at location ith element. +insertElt :: forall s arch ret. + L.Instr -- ^ Actual instruction + -> MemType -- ^ type contained in the vector + -> Integer -- ^ size of the vector + -> LLVMExpr s arch -- ^ vector expression + -> LLVMExpr s arch -- ^ element to insert + -> LLVMExpr s arch -- ^ index expression + -> LLVMGenerator s arch ret (LLVMExpr s arch) +insertElt _ ty _ _ _ (UndefExpr _) = do + return $ UndefExpr ty +insertElt instr ty n v a (ZeroExpr zty) = do + let ?err = fail + zeroExpand (proxy# :: Proxy# arch) zty $ \_archProxy tyr ex -> insertElt instr ty n v a (BaseExpr tyr ex) + +insertElt instr ty n (UndefExpr _) a i = do + insertElt instr ty n (VecExpr ty (Seq.replicate (fromInteger n) (UndefExpr ty))) a i +insertElt instr ty n (ZeroExpr _) a i = do + insertElt instr ty n (VecExpr ty (Seq.replicate (fromInteger n) (ZeroExpr ty))) a i + +insertElt instr _ n (VecExpr ty vs) a i + | Scalar _archProxy (LLVMPointerRepr _) (BitvectorAsPointerExpr _ x) <- asScalar i + , App (BVLit _ x') <- x + = constantInsert (BV.asUnsigned x') + where + constantInsert :: Integer -> LLVMGenerator s arch ret (LLVMExpr s arch) + constantInsert idx = + if (fromInteger idx < Seq.length vs) && (fromInteger idx < n) + then return $ VecExpr ty $ Seq.adjust (\_ -> a) (fromIntegral idx) vs + else fail (unlines ["invalid insertelement instruction (index out of bounds)", showInstr instr]) + +insertElt instr ty n (VecExpr _ vs) a i = do + let ?err = fail + llvmTypeAsRepr ty $ \tyr -> unpackVec (proxy# :: Proxy# arch) tyr (toList vs) $ + \ex -> insertElt instr ty n (BaseExpr (VectorRepr tyr) ex) a i + +insertElt instr _ n (BaseExpr (VectorRepr tyr) v) a i = + do mvar <- getMemVar + (idx :: Expr LLVM s NatType) + <- case asScalar i of + Scalar _archProxy (LLVMPointerRepr w) x -> + do bv <- pointerAsBitvectorExpr w x + -- The value is poisoned if the index is out of bounds. + let poison = Poison.InsertElementIndex bv + return $ + poisonSideCondition + mvar + NatRepr + poison + -- returned expression + (App (BvToNat w bv)) + -- assertion condition + (App (BVUlt w bv (App (BVLit w (BV.mkBV w n))))) + _ -> + fail (unlines ["invalid insertelement instruction", showInstr instr, show i]) + let ?err = fail + unpackOne a $ \_archProxy tyra a' -> + case testEquality tyr tyra of + Just Refl -> + return $ BaseExpr (VectorRepr tyr) (App (VectorSetEntry tyr v idx a')) + Nothing -> fail (unlines ["type mismatch in insertelement instruction", showInstr instr]) +insertElt instr _tp n v a i = fail (unlines ["invalid insertelement instruction", showInstr instr, show n, show v, show a, show i]) + +-- Given an LLVM expression of vector or structure type, select out the +-- element indicated by the sequence of given concrete indices. +extractValue + :: LLVMExpr s arch -- ^ aggregate expression + -> [Int32] -- ^ sequence of indices + -> LLVMGenerator s arch ret (LLVMExpr s arch) +extractValue v [] = return v +extractValue (UndefExpr (StructType si)) is = + extractValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, UndefExpr tp)) tps) is + where tps = map fiType $ toList $ siFields si +extractValue (UndefExpr (ArrayType n tp)) is = + extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (UndefExpr tp)) is +extractValue (ZeroExpr (StructType si)) is = + extractValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, ZeroExpr tp)) tps) is + where tps = map fiType $ toList $ siFields si +extractValue (ZeroExpr (ArrayType n tp)) is = + extractValue (VecExpr tp $ Seq.replicate (fromIntegral n) (ZeroExpr tp)) is +extractValue (StructExpr vs) (i:is) + | fromIntegral i < Seq.length vs = extractValue (snd $ Seq.index vs $ fromIntegral i) is +extractValue (VecExpr _ vs) (i:is) + | fromIntegral i < Seq.length vs = extractValue (Seq.index vs $ fromIntegral i) is +extractValue (BaseExpr (StructRepr ctx) x) (i:is) + | Just (Some idx) <- Ctx.intIndex (fromIntegral i) (Ctx.size ctx) = do + let tpr = ctx Ctx.! idx + extractValue (BaseExpr tpr (getStruct idx x)) is +extractValue (BaseExpr (VectorRepr elTp) x) (i:is) + | i >= 0 = + do let n = fromIntegral i :: Natural + extractValue (BaseExpr elTp (app (VectorGetEntry elTp x (litExpr n)))) is +extractValue _ _ = fail "invalid extractValue instruction" + + +-- Given an LLVM expression of vector or structure type, insert a new element in the posistion +-- given by the concrete indices. +insertValue + :: LLVMExpr s arch -- ^ aggregate expression + -> LLVMExpr s arch -- ^ element to insert + -> [Int32] -- ^ sequence of concrete indices + -> LLVMGenerator s arch ret (LLVMExpr s arch) +insertValue _ v [] = return v +insertValue (UndefExpr (StructType si)) v is = + insertValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, UndefExpr tp)) tps) v is + where tps = map fiType $ toList $ siFields si +insertValue (UndefExpr (ArrayType n tp)) v is = + insertValue (VecExpr tp $ Seq.replicate (fromIntegral n) (UndefExpr tp)) v is +insertValue (ZeroExpr (StructType si)) v is = + insertValue (StructExpr $ Seq.fromList $ map (\tp -> (tp, ZeroExpr tp)) tps) v is + where tps = map fiType $ toList $ siFields si +insertValue (ZeroExpr (ArrayType n tp)) v is = + insertValue (VecExpr tp $ Seq.replicate (fromIntegral n) (ZeroExpr tp)) v is +insertValue (StructExpr vs) v (i:is) + | fromIntegral i < Seq.length vs = do + let (xtp, x) = Seq.index vs (fromIntegral i) + x' <- insertValue x v is + return (StructExpr (Seq.adjust (\_ -> (xtp,x')) (fromIntegral i) vs)) +insertValue (VecExpr tp vs) v (i:is) + | fromIntegral i < Seq.length vs = do + let x = Seq.index vs (fromIntegral i) + x' <- insertValue x v is + return (VecExpr tp (Seq.adjust (\_ -> x') (fromIntegral i) vs)) +insertValue (BaseExpr (StructRepr ctx) x) v (i:is) + | Just (Some idx) <- Ctx.intIndex (fromIntegral i) (Ctx.size ctx) = do + let tpr = ctx Ctx.! idx + x' <- insertValue (BaseExpr tpr (getStruct idx x)) v is + let ?err = fail + unpackOne x' $ \_px tpr' x'' -> + case testEquality tpr tpr' of + Just Refl -> return $ BaseExpr (StructRepr ctx) (setStruct ctx x idx x'') + Nothing -> fail "insertValue was expected to return base value of same type (struct case)" +insertValue (BaseExpr (VectorRepr elTp) x) v (i:is) + | i >= 0 = + do let n = fromIntegral i :: Natural + x' <- insertValue (BaseExpr elTp (app (VectorGetEntry elTp x (litExpr n)))) v is + let ?err = fail + unpackOne x' $ \_px tpr' x'' -> + case testEquality elTp tpr' of + Just Refl -> return $ BaseExpr (VectorRepr elTp) (app (VectorSetEntry elTp x (litExpr n) x'')) + Nothing -> fail "insertValue was expected to return base value of same type (vector case)" +insertValue _ _ _ = fail "invalid insertValue instruction" + + + +evalGEP :: forall s arch ret wptr. + wptr ~ ArchWidth arch => + L.Instr -> + GEPResult (LLVMExpr s arch) -> + LLVMGenerator s arch ret (LLVMExpr s arch) +evalGEP instr (GEPResult _lanes finalMemType gep0) = finish =<< go gep0 + where + finish xs = + case Seq.viewl xs of + x Seq.:< (Seq.null -> True) -> return (BaseExpr PtrRepr x) + _ -> return (VecExpr (PtrType (MemType finalMemType)) (fmap (BaseExpr PtrRepr) xs)) + + badGEP :: LLVMGenerator s arch ret a + badGEP = fail $ unlines ["Unexpected failure when evaluating GEP", showInstr instr] + + asPtr :: LLVMExpr s arch -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) + asPtr x = + case asScalar x of + Scalar _archProxy PtrRepr p -> return p + _ -> badGEP + + go :: GEP n (LLVMExpr s arch) -> LLVMGenerator s arch ret (Seq (Expr LLVM s (LLVMPointerType wptr))) + + go (GEP_scalar_base x) = + do p <- asPtr x + return (Seq.singleton p) + + go (GEP_vector_base n x) = + do xs <- maybe badGEP (traverse (\y -> asPtr y)) (asVector x) + unless (fromIntegral (Seq.length xs) == natValue n) badGEP + return xs + + go (GEP_scatter n gep) = + do xs <- go gep + unless (Seq.length xs == 1) badGEP + return (Seq.cycleTaking (widthVal n) xs) + + go (GEP_field fi gep) = + do xs <- go gep + traverse (\x -> calcGEP_struct fi x) xs + + go (GEP_index_each mt' gep idx) = + do xs <- go gep + traverse (\x -> calcGEP_array mt' x idx) xs + + go (GEP_index_vector mt' gep idx) = + do xs <- go gep + idxs <- maybe badGEP return (asVector idx) + unless (Seq.length idxs == Seq.length xs) badGEP + traverse (\(x,i) -> calcGEP_array mt' x i) (Seq.zip xs idxs) + + +calcGEP_array :: forall wptr s arch ret. + wptr ~ ArchWidth arch => + MemType {- ^ Type of the array elements -} -> + Expr LLVM s (LLVMPointerType wptr) {- ^ Base pointer -} -> + LLVMExpr s arch {- ^ index value -} -> + LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) +calcGEP_array _typ base (ZeroExpr _) = return base + -- If the array index is the concrete number 0, then return the base + -- pointer unchanged. +calcGEP_array typ base idx = + do -- sign-extend the index value if necessary to make it + -- the same width as a pointer + (idx' :: Expr LLVM s (BVType wptr)) + <- case asScalar idx of + Scalar _archProxy (LLVMPointerRepr w) x + | Just Refl <- testEquality w PtrWidth -> + pointerAsBitvectorExpr PtrWidth x + | Just LeqProof <- testLeq (incNat w) PtrWidth -> + do x' <- pointerAsBitvectorExpr w x + return $ app (BVSext PtrWidth w x') + _ -> fail $ unwords ["Invalid index value in GEP", show idx] + + -- Calculate the size of the element memtype and check that it fits + -- in the pointer width + let dl = llvmDataLayout ?lc + let isz = G.bytesToInteger $ memTypeSize dl typ + unless (isz <= maxSigned PtrWidth) + (fail $ unwords ["Type size too large for pointer width:", show typ]) + + -- Perform the multiply + mvar <- getMemVar + off0 <- AtomExpr <$> (mkAtom $ app $ BVMul PtrWidth (app $ BVLit PtrWidth (BV.mkBV PtrWidth isz)) idx') + let off = + if isz == 0 + then off0 + else + let + -- Compute safe upper and lower bounds for the index value to + -- prevent multiplication overflow. Note that `minidx <= idx <= + -- maxidx` iff `MININT <= (isz * idx) <= MAXINT` when `isz` and + -- `idx` are considered as infinite precision integers. This + -- property holds only if we use `quot` (which rounds toward 0) + -- for the divisions in the following definitions. + + -- maximum and minimum indices to prevent multiplication overflow + maxidx = maxSigned PtrWidth `quot` (max isz 1) + minidx = minSigned PtrWidth `quot` (max isz 1) + poison = Poison.GEPOutOfBounds base idx' + cond = + (app $ BVSle PtrWidth (app $ BVLit PtrWidth (BV.mkBV PtrWidth minidx)) idx') .&& + (app $ BVSle PtrWidth idx' (app $ BVLit PtrWidth (BV.mkBV PtrWidth maxidx))) + in + -- Multiplication overflow will result in a pointer which is not "in + -- bounds" for the given allocation. We translate all GEP + -- instructions as if they had the `inbounds` flag set, so the + -- result would be a poison value. + poisonSideCondition mvar (BVRepr PtrWidth) poison off0 cond + + -- Perform the pointer offset arithmetic + callPtrAddOffset base off + + +calcGEP_struct :: + wptr ~ ArchWidth arch => + FieldInfo -> + Expr LLVM s (LLVMPointerType wptr) -> + LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) +calcGEP_struct fi base = + do -- Get the field offset and check that it fits + -- in the pointer width + let ioff = G.bytesToInteger $ fiOffset fi + unless (ioff <= maxSigned PtrWidth) + (fail $ unwords ["Field offset too large for pointer width in structure:", show ioff]) + let off = app $ BVLit PtrWidth $ BV.mkBV PtrWidth ioff + + -- Perform the pointer arithmetic and continue + -- Skip pointer arithmetic when offset is 0 + if ioff == 0 then return base else callPtrAddOffset base off + + +translateConversion :: (?transOpts :: TranslationOptions) => + L.Instr -> + L.ConvOp -> + MemType {- Input type -} -> + LLVMExpr s arch {- Value to convert -} -> + MemType {- Output type -} -> + LLVMGenerator s arch ret (LLVMExpr s arch) + +-- Bitcast is a bit of a special case, handle separately +translateConversion _instr L.BitCast inty x outty = bitCast inty x outty + +-- Perform translations pointwise on vectors +translateConversion instr op (VecType n inty) (explodeVector n -> Just xs) (VecType m outty) + | n == m = VecExpr outty <$> traverse (\x -> translateConversion instr op inty x outty) xs + +-- Otherwise, assume scalar values and do the basic conversions +translateConversion instr op _inty x outty = + let showI = showInstr instr in + case op of + L.IntToPtr -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) _, LLVMPointerRepr w') + | Just Refl <- testEquality w PtrWidth + , Just Refl <- testEquality w' PtrWidth -> return x + (Scalar _ t v, a) -> + fail (unlines ["integer-to-pointer conversion failed: " + , showI + , show v ++ " : " ++ show (pretty t) ++ " -to- " ++ show (pretty a) + ]) + (NotScalar, _) -> fail (unlines ["integer-to-pointer conversion failed: non scalar", showI]) + + L.PtrToInt -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) _, LLVMPointerRepr w') + | Just Refl <- testEquality w PtrWidth + , Just Refl <- testEquality w' PtrWidth -> return x + _ -> fail (unlines ["pointer-to-integer conversion failed", showI]) + + L.Trunc -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w')) + | Just LeqProof <- isPosNat w' + , Just LeqProof <- testLeq (incNat w') w -> + do x_bv <- pointerAsBitvectorExpr w x' + let bv' = App (BVTrunc w' w x_bv) + return (BaseExpr outty' (BitvectorAsPointerExpr w' bv')) + _ -> fail (unlines [unwords ["invalid truncation:", show x, show outty], showI]) + + L.ZExt -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w')) + | Just LeqProof <- isPosNat w + , Just LeqProof <- testLeq (incNat w) w' -> + do x_bv <- pointerAsBitvectorExpr w x' + let bv' = App (BVZext w' w x_bv) + return (BaseExpr outty' (BitvectorAsPointerExpr w' bv')) + _ -> fail (unlines [unwords ["invalid zero extension:", show x, show outty], showI]) + + L.SExt -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) x', (LLVMPointerRepr w')) + | Just LeqProof <- isPosNat w + , Just LeqProof <- testLeq (incNat w) w' -> do + do x_bv <- pointerAsBitvectorExpr w x' + let bv' = App (BVSext w' w x_bv) + return (BaseExpr outty' (BitvectorAsPointerExpr w' bv')) + _ -> fail (unlines [unwords ["invalid sign extension", show x, show outty], showI]) + +#if __GLASGOW_HASKELL__ < 900 + -- This is redundant, but GHC's pattern-match coverage checker is only + -- smart enough to realize this in 9.0 or later. + L.BitCast -> bitCast _inty x outty +#endif + + L.UiToFp -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) x', FloatRepr fi) -> do + bv <- pointerAsBitvectorExpr w x' + return $ BaseExpr (FloatRepr fi) $ App $ FloatFromBV fi RNE bv + _ -> fail (unlines [unwords ["Invalid uitofp:", show op, show x, show outty], showI]) + + L.SiToFp -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (LLVMPointerRepr w) x', FloatRepr fi) -> do + bv <- pointerAsBitvectorExpr w x' + return $ BaseExpr (FloatRepr fi) $ App $ FloatFromSBV fi RNE bv + _ -> fail (unlines [unwords ["Invalid sitofp:", show op, show x, show outty], showI]) + + L.FpToUi -> do + let demoteToInt :: (1 <= w) => NatRepr w -> Expr LLVM s (FloatType fi) -> LLVMExpr s arch + demoteToInt w v = BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w $ App $ FloatToBV w RNE v) + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (FloatRepr _) x', LLVMPointerRepr w) -> return $ demoteToInt w x' + _ -> fail (unlines [unwords ["Invalid fptoui:", show op, show x, show outty], showI]) + + L.FpToSi -> do + let demoteToInt :: (1 <= w) => NatRepr w -> Expr LLVM s (FloatType fi) -> LLVMExpr s arch + demoteToInt w v = BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w $ App $ FloatToSBV w RNE v) + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (FloatRepr _) x', LLVMPointerRepr w) -> return $ demoteToInt w x' + _ -> fail (unlines [unwords ["Invalid fptosi:", show op, show x, show outty], showI]) + + L.FpTrunc -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (FloatRepr _) x', FloatRepr fi) -> do + return $ BaseExpr (FloatRepr fi) $ App $ FloatCast fi RNE x' + _ -> fail (unlines [unwords ["Invalid fptrunc:", show op, show x, show outty], showI]) + + L.FpExt -> do + llvmTypeAsRepr outty $ \outty' -> + case (asScalar x, outty') of + (Scalar _archProxy (FloatRepr _) x', FloatRepr fi) -> do + return $ BaseExpr (FloatRepr fi) $ App $ FloatCast fi RNE x' + _ -> fail (unlines [unwords ["Invalid fpext:", show op, show x, show outty], showI]) + + +-------------------------------------------------------------------------------- +-- Bit Cast + + +bitCast :: (?lc::TypeContext,HasPtrWidth wptr, wptr ~ ArchWidth arch) => + MemType {- ^ starting type of the expression -} -> + LLVMExpr s arch {- ^ expression to cast -} -> + MemType {- ^ target type -} -> + LLVMGenerator s arch ret (LLVMExpr s arch) + +bitCast _ (ZeroExpr _) tgtT = return (ZeroExpr tgtT) + +bitCast _ (UndefExpr _) tgtT = return (UndefExpr tgtT) + +-- pointer casts always succeed +bitCast (PtrType _) expr (PtrType _) = return expr +bitCast (PtrType _) expr PtrOpaqueType = return expr +bitCast PtrOpaqueType expr (PtrType _) = return expr +bitCast PtrOpaqueType expr PtrOpaqueType = return expr + +-- casts between vectors of the same length can just be done pointwise +bitCast (VecType n srcT) (explodeVector n -> Just xs) (VecType n' tgtT) + | n == n' = VecExpr tgtT <$> traverse (\x -> bitCast srcT x tgtT) xs + +-- otherwise, cast via an intermediate integer type of common width +bitCast srcT expr tgtT = mb =<< runMaybeT ( + case (memTypeBitwidth srcT, memTypeBitwidth tgtT) of + (Just w1, Just w2) | w1 == w2 -> castToInt srcT expr >>= castFromInt tgtT w2 + _ -> mzero) + + where + mb = maybe (err [ "*** Invalid coercion of expression" + , indent (show expr) + , "of type" + , indent (show srcT) + , "to type" + , indent (show tgtT) + ]) return + err msg = reportError $ fromString $ unlines ("[bitCast] Failed to perform cast:" : msg) + indent msg = " " ++ msg + +castToInt :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) => + MemType {- ^ type of input expression -} -> + LLVMExpr s arch -> + MaybeT (LLVMGenerator' s arch ret) (LLVMExpr s arch) +castToInt (IntType w) (BaseExpr (LLVMPointerRepr wrepr) x) + | w == natValue wrepr + = lift (BaseExpr (BVRepr wrepr) <$> pointerAsBitvectorExpr wrepr x) + +castToInt FloatType (BaseExpr (FloatRepr SingleFloatRepr) x) + = return (BaseExpr (BVRepr (knownNat @32)) (app (FloatToBinary SingleFloatRepr x))) +castToInt DoubleType (BaseExpr (FloatRepr DoubleFloatRepr) x) + = return (BaseExpr (BVRepr (knownNat @64)) (app (FloatToBinary DoubleFloatRepr x))) +castToInt X86_FP80Type (BaseExpr (FloatRepr X86_80FloatRepr) x) + = return (BaseExpr (BVRepr (knownNat @80)) (app (FloatToBinary X86_80FloatRepr x))) + +castToInt (VecType n tp) (explodeVector n -> Just xs) = + do xs' <- traverse (castToInt tp) (toList xs) + MaybeT (return (vecJoin xs')) +castToInt _ _ = mzero + +castFromInt :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) => + MemType {- ^ target type -} -> + Natural {- ^ bitvector width in bits -} -> + LLVMExpr s arch -> MaybeT (LLVMGenerator' s arch ret) (LLVMExpr s arch) + +castFromInt (IntType w1) w2 (BaseExpr (BVRepr w) x) + | w1 == w2, w1 == natValue w + = return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w x)) + +castFromInt FloatType 32 (BaseExpr (BVRepr w) x) + | Just Refl <- testEquality w (knownNat @32) + = return (BaseExpr (FloatRepr SingleFloatRepr) (app (FloatFromBinary SingleFloatRepr x))) + +castFromInt DoubleType 64 (BaseExpr (BVRepr w) x) + | Just Refl <- testEquality w (knownNat @64) + = return (BaseExpr (FloatRepr DoubleFloatRepr) (app (FloatFromBinary DoubleFloatRepr x))) + +castFromInt X86_FP80Type 80 (BaseExpr (BVRepr w) x) + | Just Refl <- testEquality w (knownNat @80) + = return (BaseExpr (FloatRepr X86_80FloatRepr) (app (FloatFromBinary X86_80FloatRepr x))) + +castFromInt (VecType n tp) w expr + | n > 0 + , (w',0) <- w `divMod` n + , Some wrepr' <- mkNatRepr w' + , Just LeqProof <- isPosNat wrepr' + = do xs <- MaybeT (return (vecSplit wrepr' expr)) + VecExpr tp . Seq.fromList <$> traverse (castFromInt tp w') xs +castFromInt _ _ _ = mzero + + +-- | Join the elements of a vector into a single bit-vector value. +-- The resulting bit-vector would be of length at least one. +vecJoin :: (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch) => + [LLVMExpr s arch] {- ^ Join these vector elements -} -> + Maybe (LLVMExpr s arch) +vecJoin exprs = + do (a,ys) <- List.uncons exprs + Scalar _archProxy (BVRepr (n :: NatRepr n)) e1 <- return (asScalar a) + if null ys + then do LeqProof <- testLeq (knownNat @1) n + return (BaseExpr (BVRepr n) e1) + else do BaseExpr (BVRepr m) e2 <- vecJoin ys + let p1 = leqZero @n + p2 = leqProof (knownNat @1) m + (LeqProof,LeqProof) <- return (leqAdd2 p1 p2, leqAdd2 p2 p1) + let bits u v x y = bitVal (addNat u v) (BVConcat u v x y) + return $! case llvmDataLayout ?lc ^. intLayout of + LittleEndian -> bits m n e2 e1 + BigEndian -> bits n m e1 e2 + + +bitVal :: + (1 <= n) => + NatRepr n -> + App LLVM (Expr LLVM s) (BVType n) -> + LLVMExpr s arch +bitVal n e = BaseExpr (BVRepr n) (App e) + + +-- | Split a single bit-vector value into a vector of value of the given width. +vecSplit :: forall s n w arch. (?lc::TypeContext,HasPtrWidth w, w ~ ArchWidth arch, 1 <= n) => + NatRepr n {- ^ Length of a single element -} -> + LLVMExpr s arch {- ^ Bit-vector value -} -> + Maybe [ LLVMExpr s arch ] +vecSplit elLen expr = + do Scalar _archProxy (BVRepr totLen) e <- return (asScalar expr) + let getEl :: NatRepr offset -> Maybe [ LLVMExpr s arch ] + getEl offset = let end = addNat offset elLen + in case testLeq end totLen of + Just LeqProof -> + do rest <- getEl end + let x = bitVal elLen + (BVSelect offset elLen totLen e) + return (x : rest) + Nothing -> + do Refl <- testEquality offset totLen + return [] + els <- getEl (knownNat @0) + -- in `els` the least significant chunk is first + + return $! case lay ^. intLayout of + LittleEndian -> els + BigEndian -> reverse els + where + lay = llvmDataLayout ?lc + + +bitop :: (?transOpts :: TranslationOptions) => + L.BitOp -> + MemType -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +bitop op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) = + VecExpr tp <$> sequence (Seq.zipWith (\x y -> bitop op tp x y) xs ys) + +bitop op _ x y = + case (asScalar x, asScalar y) of + (Scalar _archProxy (LLVMPointerRepr w) x', + Scalar _archPrxy' (LLVMPointerRepr w') y') + | Just Refl <- testEquality w w' + , Just LeqProof <- isPosNat w -> do + xbv <- pointerAsBitvectorExpr w x' + ybv <- pointerAsBitvectorExpr w y' + ex <- raw_bitop op w xbv ybv + return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w ex)) + + _ -> fail $ unwords ["bitwise operation on unsupported values", show x, show y] + +raw_bitop :: (?transOpts :: TranslationOptions, 1 <= w) => + L.BitOp -> + NatRepr w -> + Expr LLVM s (BVType w) -> + Expr LLVM s (BVType w) -> + LLVMGenerator s arch ret (Expr LLVM s (BVType w)) +raw_bitop op w a b = + do mvar <- getMemVar + let withSideConds val lst = sideConditionsA mvar (BVRepr w) val lst + let noLaxArith = not (laxArith ?transOpts) + case op of + L.And -> return $ App (BVAnd w a b) + L.Or -> return $ App (BVOr w a b) + L.Xor -> return $ App (BVXor w a b) + + L.Shl nuw nsw -> do + let wlit = App (BVLit w (BV.width w)) + result <- AtomExpr <$> mkAtom (App (BVShl w a b)) + withSideConds result + [ ( noLaxArith + , pure $ App (BVUlt w b wlit) -- TODO: is this the right condition? + , UB.PoisonValueCreated $ Poison.ShlOp2Big a b + ) + , ( nuw && noLaxArith + , fmap (App . BVEq w a . AtomExpr) + (mkAtom (App (BVLshr w result b))) + , UB.PoisonValueCreated $ Poison.ShlNoUnsignedWrap a b + ) + , ( nsw && noLaxArith + , fmap (App . BVEq w a . AtomExpr) + (mkAtom (App (BVAshr w result b))) + , UB.PoisonValueCreated $ Poison.ShlNoSignedWrap a b + ) + ] + + L.Lshr exact -> do + let wlit = App (BVLit w (BV.width w)) + result <- AtomExpr <$> mkAtom (App (BVLshr w a b)) + withSideConds result + [ ( noLaxArith + , pure $ App (BVUlt w b wlit) + , UB.PoisonValueCreated $ Poison.LshrOp2Big a b + ) + , ( exact && noLaxArith + , fmap (App . BVEq w a . AtomExpr) + (mkAtom (App (BVShl w result b))) + , UB.PoisonValueCreated $ Poison.LshrExact a b + ) + ] + + L.Ashr exact + | Just LeqProof <- isPosNat w -> do + let wlit = App (BVLit w (BV.width w)) + result <- AtomExpr <$> mkAtom (App (BVAshr w a b)) + withSideConds result + [ ( noLaxArith + , pure $ App (BVUlt w b wlit) + , UB.PoisonValueCreated $ Poison.AshrOp2Big a b + ) + , ( exact && noLaxArith + , fmap (App . BVEq w a) + (AtomExpr <$> mkAtom (App (BVShl w result b))) + , UB.PoisonValueCreated $ Poison.AshrExact a b + ) + ] + + | otherwise -> fail "cannot arithmetic right shift a 0-width integer" + + +-- | Translate an LLVM integer operation into a Crucible CFG expression. +-- +-- Poison values can arise from such operations. +intop :: forall w s arch ret. (?transOpts :: TranslationOptions, 1 <= w) + => L.ArithOp + -> NatRepr w + -> Expr LLVM s (BVType w) + -> Expr LLVM s (BVType w) + -> LLVMGenerator s arch ret (Expr LLVM s (BVType w)) +intop op w a b = + do mvar <- getMemVar + let withSideConds val lst = sideConditionsA mvar (BVRepr w) val lst + let withPoison val xs = + do v <- AtomExpr <$> mkAtom val + withSideConds v $ map (\(d, e, c) -> (d, pure e, UB.PoisonValueCreated c)) xs + let z = App (BVLit w (BV.zero w)) + let bNeqZero = \ub -> (True, pure (notExpr (App (BVEq w z b))), ub) + let neg1 = App (BVLit w (BV.mkBV w (-1))) + let minInt = App (BVLit w (BV.minSigned w)) + let noLaxArith = not (laxArith ?transOpts) + case op of + L.Add nuw nsw -> withPoison (App (BVAdd w a b)) + [ ( nuw && noLaxArith + , notExpr (App (BVCarry w a b)) + , Poison.AddNoUnsignedWrap a b + ) + , ( nsw && noLaxArith + , notExpr (App (BVSCarry w a b)) + , Poison.AddNoSignedWrap a b + ) + ] + + L.Sub nuw nsw -> withPoison (App (BVSub w a b)) + [ ( nuw && noLaxArith + , notExpr (App (BVUlt w a b)) + , Poison.SubNoUnsignedWrap a b + ) + , ( nsw && noLaxArith + , notExpr (App (BVSBorrow w a b)) + , Poison.SubNoSignedWrap a b + ) + ] + + L.Mul nuw nsw -> do + let w' = addNat w w + Just LeqProof <- return $ isPosNat w' + Just LeqProof <- return $ testLeq (incNat w) w' + + prod <- AtomExpr <$> mkAtom (App (BVMul w a b)) + withSideConds prod + [ ( nuw && noLaxArith + , do + az <- AtomExpr <$> mkAtom (App (BVZext w' w a)) + bz <- AtomExpr <$> mkAtom (App (BVZext w' w b)) + wideprod <- AtomExpr <$> mkAtom (App (BVMul w' az bz)) + prodz <- AtomExpr <$> mkAtom (App (BVZext w' w prod)) + return (App (BVEq w' wideprod prodz)) + , UB.PoisonValueCreated $ Poison.MulNoUnsignedWrap a b + ) + , ( nsw && noLaxArith + , do + as <- AtomExpr <$> mkAtom (App (BVSext w' w a)) + bs <- AtomExpr <$> mkAtom (App (BVSext w' w b)) + wideprod <- AtomExpr <$> mkAtom (App (BVMul w' as bs)) + prods <- AtomExpr <$> mkAtom (App (BVSext w' w prod)) + return (App (BVEq w' wideprod prods)) + , UB.PoisonValueCreated $ Poison.MulNoSignedWrap a b + ) + ] + + L.UDiv exact -> do + q <- AtomExpr <$> mkAtom (App (BVUdiv w a b)) + withSideConds q + [ ( exact && noLaxArith + , fmap (App . BVEq w a . AtomExpr) + (mkAtom (App (BVMul w q b))) + , UB.PoisonValueCreated $ Poison.UDivExact a b + ) + , bNeqZero (UB.UDivByZero a b) + ] + + L.SDiv exact + | Just LeqProof <- isPosNat w -> do + q <- AtomExpr <$> mkAtom (App (BVSdiv w a b)) + withSideConds q + [ ( exact && noLaxArith + , fmap (App . BVEq w a . AtomExpr) + (mkAtom (App (BVMul w q b))) + , UB.PoisonValueCreated $ Poison.SDivExact a b + ) + , ( noLaxArith + , pure (notExpr (App (BVEq w neg1 b) .&& App (BVEq w minInt a))) + , UB.SDivOverflow a b + ) + , bNeqZero (UB.SDivByZero a b) + ] + + | otherwise -> fail "cannot take the signed quotient of a 0-width bitvector" + + L.URem -> withSideConds (App (BVUrem w a b)) [ bNeqZero (UB.URemByZero a b) ] + + L.SRem + | Just LeqProof <- isPosNat w -> + do r <- AtomExpr <$> mkAtom (App (BVSrem w a b)) + withSideConds r + [ ( noLaxArith + , pure (notExpr (App (BVEq w neg1 b) .&& App (BVEq w minInt a))) + , UB.SRemOverflow a b + ) + , bNeqZero (UB.SRemByZero a b) + ] + + | otherwise -> fail "cannot take the signed remainder of a 0-width bitvector" + + _ -> fail $ unwords ["unsupported integer arith operation", show op] + +caseptr + :: (1 <= w) + => NatRepr w + -> TypeRepr a + -> (Expr LLVM s (BVType w) -> + LLVMGenerator s arch ret (Expr LLVM s a)) + -> (Expr LLVM s NatType -> Expr LLVM s (BVType w) -> + LLVMGenerator s arch ret (Expr LLVM s a)) + -> Expr LLVM s (LLVMPointerType w) + -> LLVMGenerator s arch ret (Expr LLVM s a) + +caseptr w tpr bvCase ptrCase x = + case x of + PointerExpr _ blk off -> + case asApp blk of + Just (NatLit 0) -> bvCase off + Just (NatLit _) -> ptrCase blk off + _ -> ptrSwitch blk off + + _ -> do a_x <- forceEvaluation x + blk <- forceEvaluation (App (ExtensionApp (LLVM_PointerBlock w a_x))) + off <- forceEvaluation (App (ExtensionApp (LLVM_PointerOffset w a_x))) + ptrSwitch blk off + where + ptrSwitch blk off = + do let cond = (blk .== litExpr 0) + c_label <- newLambdaLabel' tpr + bv_label <- defineBlockLabel (bvCase off >>= jumpToLambda c_label) + ptr_label <- defineBlockLabel (ptrCase blk off >>= jumpToLambda c_label) + continueLambda c_label (branch cond bv_label ptr_label) + +atomicRWOp :: + L.AtomicRWOp -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +atomicRWOp op x y = + case (asScalar x, asScalar y) of + (Scalar _archProxy (LLVMPointerRepr (w :: NatRepr w)) x', Scalar _archProxy' (LLVMPointerRepr w') y') + | Just Refl <- testEquality w w' + -> do xbv <- pointerAsBitvectorExpr w x' + ybv <- pointerAsBitvectorExpr w y' + let newval = case op of + L.AtomicXchg -> ybv + L.AtomicAdd -> app $ BVAdd w xbv ybv + L.AtomicSub -> app $ BVSub w xbv ybv + L.AtomicAnd -> app $ BVAnd w xbv ybv + L.AtomicNand -> app $ BVNot w $ app $ BVAnd w xbv ybv + L.AtomicOr -> app $ BVOr w xbv ybv + L.AtomicXor -> app $ BVXor w xbv ybv + L.AtomicMax -> app $ BVSMax w xbv ybv + L.AtomicMin -> app $ BVSMin w xbv ybv + L.AtomicUMax -> app $ BVUMax w xbv ybv + L.AtomicUMin -> app $ BVUMin w xbv ybv + return $ BaseExpr (LLVMPointerRepr w) $ BitvectorAsPointerExpr w newval + + _ -> fail $ unlines [ "atomicRW operation on incompatible values" + , "Operation: " ++ show op + , "Value 1: " ++ show x + , "Value 2: " ++ show y + ] + +floatingCompare :: + L.FCmpOp -> + MemType -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +floatingCompare op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) = + VecExpr (IntType 1) <$> sequence (Seq.zipWith (\x y -> floatingCompare op tp x y) xs ys) + +floatingCompare op _ x y = + do b <- scalarFloatingCompare op x y + return (BaseExpr (LLVMPointerRepr (knownNat :: NatRepr 1)) + (BitvectorAsPointerExpr knownNat (App (BoolToBV knownNat b)))) + +scalarFloatingCompare :: + L.FCmpOp -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (Expr LLVM s BoolType) +scalarFloatingCompare op x y = + case (asScalar x, asScalar y) of + (Scalar _archProxy (FloatRepr fi) x', + Scalar _archPrxy' (FloatRepr fi') y') + | Just Refl <- testEquality fi fi' -> + return (floatcmp op x' y') + + _ -> fail $ unwords ["Floating point comparison on incompatible values", show x, show y] + +floatcmp :: + L.FCmpOp -> + Expr LLVM s (FloatType fi) -> + Expr LLVM s (FloatType fi) -> + Expr LLVM s BoolType +floatcmp op a b = + let isNaNCond = App . FloatIsNaN + -- True if a is NAN or b is NAN + unoCond = App $ Or (isNaNCond a) (isNaNCond b) + mkUno c = App $ Or c unoCond + in case op of + L.Ftrue -> App $ BoolLit True + L.Ffalse -> App $ BoolLit False + L.Foeq -> App $ FloatFpEq a b + L.Folt -> App $ FloatLt a b + L.Fole -> App $ FloatLe a b + L.Fogt -> App $ FloatGt a b + L.Foge -> App $ FloatGe a b + L.Fone -> App $ FloatFpApart a b + L.Fueq -> mkUno $ App $ FloatFpEq a b + L.Fult -> mkUno $ App $ FloatLt a b + L.Fule -> mkUno $ App $ FloatLe a b + L.Fugt -> mkUno $ App $ FloatGt a b + L.Fuge -> mkUno $ App $ FloatGe a b + L.Fune -> mkUno $ App $ FloatFpApart a b + L.Ford -> App $ And (App $ Not $ isNaNCond a) (App $ Not $ isNaNCond b) + L.Funo -> unoCond + + +integerCompare :: + L.ICmpOp -> + MemType -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +integerCompare op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) = + VecExpr (IntType 1) <$> sequence (Seq.zipWith (\x y -> integerCompare op tp x y) xs ys) + +integerCompare op _ x y = do + b <- scalarIntegerCompare op x y + return (BaseExpr (LLVMPointerRepr (knownNat :: NatRepr 1)) + (BitvectorAsPointerExpr knownNat (App (BoolToBV knownNat b)))) + +scalarIntegerCompare :: + L.ICmpOp -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (Expr LLVM s BoolType) +scalarIntegerCompare op x y = + case (asScalar x, asScalar y) of + (Scalar _archProxy (LLVMPointerRepr w) x'', Scalar _archProxy' (LLVMPointerRepr w') y'') + | Just Refl <- testEquality w w' + , Just Refl <- testEquality w PtrWidth + -> pointerCmp op x'' y'' + | Just Refl <- testEquality w w' + -> do xbv <- pointerAsBitvectorExpr w x'' + ybv <- pointerAsBitvectorExpr w y'' + return (intcmp w op xbv ybv) + _ -> fail $ unlines [ "arithmetic comparison on incompatible values" + , "Comparison: " ++ show op + , "Value 1: " ++ show x + , "Value 2: " ++ show y + ] + +intcmp :: (1 <= w) + => NatRepr w + -> L.ICmpOp + -> Expr LLVM s (BVType w) + -> Expr LLVM s (BVType w) + -> Expr LLVM s BoolType +intcmp w op a b = + case op of + L.Ieq -> App (BVEq w a b) + L.Ine -> App (Not (App (BVEq w a b))) + L.Iult -> App (BVUlt w a b) + L.Iule -> App (BVUle w a b) + L.Iugt -> App (BVUlt w b a) + L.Iuge -> App (BVUle w b a) + L.Islt -> App (BVSlt w a b) + L.Isle -> App (BVSle w a b) + L.Isgt -> App (BVSlt w b a) + L.Isge -> App (BVSle w b a) + +pointerCmp + :: (wptr ~ ArchWidth arch) + => L.ICmpOp + -> Expr LLVM s (LLVMPointerType wptr) + -> Expr LLVM s (LLVMPointerType wptr) + -> LLVMGenerator s arch ret (Expr LLVM s BoolType) +pointerCmp op x y = + caseptr PtrWidth knownRepr + (\x_bv -> + caseptr PtrWidth knownRepr + (\y_bv -> return $ intcmp PtrWidth op x_bv y_bv) + (\_ _ -> ptr_bv_compare x_bv y) + y) + (\_ _ -> + caseptr PtrWidth knownRepr + (\y_bv -> ptr_bv_compare y_bv x) + (\_ _ -> ptrOp) + y) + x + where + + -- Special case: a pointer can be compared for equality with an integer, as long as + -- that integer is 0, representing the null pointer. + ptr_bv_compare bv ptr = do + -- TODO: We can't use assertUndefinedSym here since the type variable 'sym' + -- isn't in scope. How should this be fixed? + assertExpr + (App (BVEq PtrWidth bv (App (BVLit PtrWidth (BV.zero PtrWidth))))) + (litExpr "Undefined comparison between pointer and integer") + case op of + L.Ieq -> callIsNull PtrWidth ptr + L.Ine -> App . Not <$> callIsNull PtrWidth ptr + _ -> reportError $ litExpr $ Text.pack $ unlines $ + [ "Arithmetic comparison on incompatible values" + , "Comparison operation: " ++ show op + , "Value 1: " ++ show x + , "Value 2: " ++ show y + ] + + ptrOp = + do memVar <- getMemVar + case op of + L.Ieq -> do + isEq <- extensionStmt (LLVM_PtrEq memVar x y) + return $ isEq + L.Ine -> do + isEq <- extensionStmt (LLVM_PtrEq memVar x y) + return $ App (Not isEq) + L.Iule -> do + isLe <- extensionStmt (LLVM_PtrLe memVar x y) + return $ isLe + L.Iult -> do + isGe <- extensionStmt (LLVM_PtrLe memVar y x) + return $ App (Not isGe) + L.Iuge -> do + isGe <- extensionStmt (LLVM_PtrLe memVar y x) + return $ isGe + L.Iugt -> do + isLe <- extensionStmt (LLVM_PtrLe memVar x y) + return $ App (Not isLe) + _ -> reportError $ litExpr $ Text.pack $ unlines $ + [ "Signed comparison on pointer values" + , "Comparison operation: " ++ show op + , "Value 1:" ++ show x + , "Value 2" ++ show y + ] + +pointerOp + :: (wptr ~ ArchWidth arch, ?transOpts :: TranslationOptions) + => L.ArithOp + -> Expr LLVM s (LLVMPointerType wptr) + -> Expr LLVM s (LLVMPointerType wptr) + -> LLVMGenerator s arch ret (Expr LLVM s (LLVMPointerType wptr)) +pointerOp op x y = + caseptr PtrWidth PtrRepr + (\x_bv -> + caseptr PtrWidth PtrRepr + (\y_bv -> BitvectorAsPointerExpr PtrWidth <$> + intop op PtrWidth x_bv y_bv) + (\_ _ -> bv_ptr_op x_bv) + y) + (\_ _ -> + caseptr PtrWidth PtrRepr + (\y_bv -> ptr_bv_op y_bv) + (\_ _ -> ptr_ptr_op) + y) + x + where + ptr_bv_op y_bv = + case op of + L.Add _ _ -> + callPtrAddOffset x y_bv + L.Sub _ _ -> + do let off = App (BVSub PtrWidth (App $ BVLit PtrWidth (BV.zero PtrWidth)) y_bv) + callPtrAddOffset x off + _ -> err + + bv_ptr_op x_bv = + case op of + L.Add _ _ -> callPtrAddOffset y x_bv + _ -> err + + ptr_ptr_op = + case op of + L.Sub _ _ -> BitvectorAsPointerExpr PtrWidth <$> callPtrSubtract x y + _ -> err + + err = reportError $ litExpr $ Text.pack $ unlines $ + [ "Invalid pointer operation" + , "Operation: " ++ show op + , "Value 1: " ++ show x + , "Value 2: " ++ show y + ] + + +baseSelect :: + (?lc :: TypeContext, HasPtrWidth wptr, wptr ~ ArchWidth arch) => + LLVMExpr s arch {- ^ Selection expression -} -> + LLVMExpr s arch {- ^ true expression -} -> + LLVMExpr s arch {- ^ false expression -} -> + LLVMGenerator s arch ret (Maybe (LLVMExpr s arch)) +baseSelect (asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c) (asScalar -> Scalar _ xtp x) (asScalar -> Scalar _ ytp y) + | Just Refl <- testEquality xtp ytp + , LLVMPointerRepr w <- xtp + = do c' <- callIntToBool wc c + z <- forceEvaluation (App (ExtensionApp (LLVM_PointerIte w c' x y))) + return (Just (BaseExpr (LLVMPointerRepr w) z)) + +baseSelect (asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c) (asScalar -> Scalar _ xtp x) (asScalar -> Scalar _ ytp y) + | Just Refl <- testEquality xtp ytp + , AsBaseType btp <- asBaseType xtp + = do c' <- callIntToBool wc c + z <- forceEvaluation (app (BaseIte btp c' x y)) + return (Just (BaseExpr xtp z)) + +baseSelect _ _ _ = return Nothing + + +translateSelect :: + (?lc :: TypeContext, HasPtrWidth wptr, wptr ~ ArchWidth arch) => + L.Instr {- ^ The instruction to translate -} -> + (LLVMExpr s arch -> LLVMGenerator s arch ret ()) + {- ^ A continuation to assign the produced value of this instruction to a register -} -> + MemType {- ^ Type of the selector variable -} -> + LLVMExpr s arch {- ^ Selection expression -} -> + MemType {- ^ Type of the select branches -} -> + LLVMExpr s arch {- ^ true expression -} -> + LLVMExpr s arch {- ^ false expression -} -> + LLVMGenerator s arch ret () +translateSelect instr assign_f + (VecType n _) (explodeVector n -> Just cs) + (VecType m eltp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) + | n == m + = do zs <- forM [0..n-1] $ \i -> + do Just c <- return $ Seq.lookup (fromIntegral i) cs + Just x <- return $ Seq.lookup (fromIntegral i) xs + Just y <- return $ Seq.lookup (fromIntegral i) ys + mz <- baseSelect c x y + maybe (fail $ unlines ["invalid select operation", showInstr instr]) return mz + + assign_f (VecExpr eltp (Seq.fromList zs)) + +translateSelect instr assign_f + _ctp c + (VecType n eltp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) + = do zs <- forM [0..n-1] $ \i -> + do Just x <- return $ Seq.lookup (fromIntegral i) xs + Just y <- return $ Seq.lookup (fromIntegral i) ys + mz <- baseSelect c x y + maybe (fail $ unlines ["invalid select operation", showInstr instr]) return mz + + assign_f (VecExpr eltp (Seq.fromList zs)) + +translateSelect _ assign_f _ctp c@(asScalar -> Scalar _archProxy (LLVMPointerRepr wc) c') _tp x y + = do mz <- baseSelect c x y + case mz of + Just z -> assign_f z + Nothing -> + do c'' <- callIntToBool wc c' + ifte_ c'' (assign_f x) (assign_f y) + +translateSelect instr _ _ _ _ _ _ = + fail $ unlines ["invalid select operation", showInstr instr] + + +-- | Do the heavy lifting of translating LLVM instructions to crucible code. +generateInstr :: forall s arch ret a. + (?transOpts :: TranslationOptions) => + TypeRepr ret {- ^ Type of the function return value -} -> + L.BlockLabel {- ^ The label of the current LLVM basic block -} -> + Set L.Ident {- ^ Set of usable identifiers -} -> + L.Instr {- ^ The instruction to translate -} -> + (LLVMExpr s arch -> LLVMGenerator s arch ret ()) + {- ^ A continuation to assign the produced value of this instruction to a register -} -> + LLVMGenerator s arch ret a + {- ^ A continuation for translating the remaining statements in this function. + Straightline instructions should enter this continuation, + but block-terminating instructions should not. -} -> + LLVMGenerator s arch ret a +generateInstr retType lab defSet instr assign_f k = + case instr of + -- skip phi instructions, they are handled in definePhiBlock + L.Phi _ _ -> k + L.Comment _ -> k + L.Unreachable -> reportError "LLVM unreachable code" + + L.ExtractValue x is -> do + x' <- transTypedValue x + v <- extractValue x' is + assign_f v + k + + L.InsertValue x v is -> do + x' <- transTypedValue x + v' <- transTypedValue v + y <- insertValue x' v' is + assign_f y + k + + L.ExtractElt x i -> + case x of + L.Typed (L.Vector n ty) x' -> do + ty' <- liftMemType' ty + x'' <- transValue (VecType (fromIntegral n) ty') x' + i' <- transValue (IntType 64) i -- FIXME? this is a bit of a hack, since the llvm-pretty + -- AST doesn't track the size of the index value + y <- extractElt instr ty' (fromIntegral n) x'' i' + assign_f y + k + + _ -> fail $ unwords ["expected vector type in extractelement instruction:", show x] + + L.InsertElt x v i -> + case x of + L.Typed (L.Vector n ty) x' -> do + ty' <- liftMemType' ty + x'' <- transValue (VecType (fromIntegral n) ty') x' + v' <- transTypedValue v + i' <- transValue (IntType 64) i -- FIXME? this is a bit of a hack, since the llvm-pretty + -- AST doesn't track the size of the index value + y <- insertElt instr ty' (fromIntegral n) x'' v' i' + assign_f y + k + + _ -> fail $ unwords ["expected vector type in insertelement instruction:", show x] + + L.ShuffleVector sV1 sV2 sIxes -> + case (L.typedType sV1, L.typedType sIxes) of + (L.Vector m ty, L.Vector n (L.PrimType (L.Integer 32))) -> + do elTy <- liftMemType' ty + let inL :: Num b => b + inL = fromIntegral m + + inV = VecType inL elTy + + outL :: Num b => b + outL = fromIntegral n + + xv1 <- transValue inV (L.typedValue sV1) + xv2 <- transValue inV sV2 + xis <- transValue (VecType outL (IntType 32)) (L.typedValue sIxes) + + case (explodeVector inL xv1, explodeVector inL xv2, explodeVector outL xis) of + (Just v1, Just v2, Just is) -> + do let getV x = + case x of + UndefExpr _ -> return $ UndefExpr elTy + ZeroExpr _ -> return $ Seq.index v1 0 + BaseExpr (LLVMPointerRepr _) (BitvectorAsPointerExpr _ (App (BVLit _ i))) + | BV.asUnsigned i < inL -> return $ Seq.index v1 (fromIntegral (BV.asUnsigned i)) + | inL <= BV.asUnsigned i && BV.asUnsigned i < 2*inL -> + return $ Seq.index v2 (fromIntegral (BV.asUnsigned i - inL)) + + _ -> fail $ unwords ["[shuffle] Expected literal index values but got", show x] + + is' <- traverse getV is + assign_f (VecExpr elTy is') + k + + _ -> fail $ unlines ["[shuffle] unexpected values:" + , showInstr instr + , show xv1, show xv2, show xis] + + (t1,t2) -> fail $ unlines ["[shuffle] Type error", show t1, show t2 ] + + + L.Alloca tp num align -> do + tp' <- liftMemType' tp + let dl = llvmDataLayout ?lc + let tp_sz = memTypeSize dl tp' + let tp_sz' = app $ BVLit PtrWidth $ G.bytesToBV PtrWidth tp_sz + + sz <- case num of + Nothing -> return $ tp_sz' + Just num' -> do + n <- transTypedValue num' + case n of + ZeroExpr _ -> return $ app $ BVLit PtrWidth (BV.zero PtrWidth) + BaseExpr (LLVMPointerRepr w) x + | Just Refl <- testEquality w PtrWidth -> + do x' <- pointerAsBitvectorExpr w x + return $ app $ BVMul PtrWidth x' tp_sz' + _ -> fail $ "Invalid alloca argument: " ++ show num + + -- LLVM documentation regarding `alloca` alignment: + -- + -- If a constant alignment is specified, the value result of the + -- allocation is guaranteed to be aligned to at least that + -- boundary. The alignment may not be greater than 1 << 29. If + -- not specified, or if zero, the target can choose to align the + -- allocation on any convenient boundary compatible with the + -- type. + alignment <- + case align of + Just a | a > 0 -> + case toAlignment (G.toBytes a) of + Nothing -> fail $ "Invalid alignment value in alloca: " ++ show a + Just al -> return al + _ -> return (memTypeAlign dl tp') + + p <- callAlloca sz alignment + assign_f (BaseExpr (LLVMPointerRepr PtrWidth) p) + k + + -- We don't care if it's atomic, since the symbolic simulator is + -- effectively single-threaded. + L.Load tp ptr _atomic align -> do + resTy <- liftMemType' tp + ptr' <- transTypedValue ptr + llvmTypeAsRepr resTy $ \expectTy -> do + let a0 = memTypeAlign (llvmDataLayout ?lc) resTy + let align' = fromMaybe a0 (toAlignment . G.toBytes =<< align) + res <- callLoad resTy expectTy ptr' align' + assign_f res + k + + -- We don't care if it's atomic, since the symbolic simulator is + -- effectively single-threaded. + L.Store v ptr _atomic align -> do + vTp <- liftMemType' (L.typedType v) + ptr' <- transTypedValue ptr + let a0 = memTypeAlign (llvmDataLayout ?lc) vTp + let align' = fromMaybe a0 (toAlignment . G.toBytes =<< align) + v' <- transValue vTp (L.typedValue v) + callStore vTp ptr' v' align' + k + + -- NB We treat every GEP as though it has the "inbounds" flag set; + -- thus, the calculation of out-of-bounds pointers results in + -- a runtime error. + L.GEP inbounds baseTy basePtr elts -> do + runExceptT (translateGEP inbounds baseTy basePtr elts) >>= \case + Left err -> reportError $ fromString $ unlines ["Error translating GEP", err] + Right gep -> + do gep' <- traverse (\v -> transTypedValue v) gep + v <- evalGEP instr gep' + assign_f v + k + + L.Conv op x outty -> do + do tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + outty' <- liftMemType' outty + v <- translateConversion instr op tp x' outty' + assign_f v + k + + L.Call tailcall fnTy fn args -> + callFunction defSet instr tailcall fnTy fn args assign_f >> k + + L.Invoke fnTy fn args normLabel _unwindLabel -> do + do callFunction defSet instr False fnTy fn args assign_f + definePhiBlock lab normLabel + + L.CallBr fnTy fn args normLabel otherLabels -> do + do callFunction defSet instr False fnTy fn args assign_f + for_ otherLabels $ \lab' -> void (definePhiBlock lab lab') + definePhiBlock lab normLabel + + L.Bit op x y -> + do tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + y' <- transValue tp y + v <- bitop op tp x' y' + assign_f v + k + + L.Arith op x y -> + do tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + y' <- transValue tp y + v <- arithOp op tp x' y' + assign_f v + k + + L.UnaryArith op x -> + do tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + v <- unaryArithOp op tp x' + assign_f v + k + + L.FCmp op x y -> do + tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + y' <- transValue tp y + cmp <- floatingCompare op tp x' y' + assign_f cmp + k + + L.ICmp op x y -> do + tp <- liftMemType' (L.typedType x) + x' <- transTypedValue x + y' <- transTypedValue (L.Typed (L.typedType x) y) + cmp <- integerCompare op tp x' y' + assign_f cmp + k + + L.Select c x y -> do + ctp <- liftMemType' (L.typedType c) + c' <- transValue ctp (L.typedValue c) + + tp <- liftMemType' (L.typedType x) + x' <- transValue tp (L.typedValue x) + y' <- transValue tp y + + translateSelect instr assign_f ctp c' tp x' y' + k + + L.Jump l' -> definePhiBlock lab l' + + L.Br v l1 l2 -> do + v' <- transTypedValue v + e' <- case asScalar v' of + Scalar _archProxy (LLVMPointerRepr w) e -> callIntToBool w e + _ -> fail "expected boolean condition on branch" + + phi1 <- defineBlockLabel (definePhiBlock lab l1) + phi2 <- defineBlockLabel (definePhiBlock lab l2) + branch e' phi1 phi2 + + L.Switch x def branches -> do + x' <- transTypedValue x + case asScalar x' of + Scalar _archProxy (LLVMPointerRepr w) x'' -> + do bv <- pointerAsBitvectorExpr w x'' + buildSwitch w bv lab def branches + _ -> fail $ unwords ["expected integer value in switch", showInstr instr] + + L.Ret v -> do v' <- transTypedValue v + let ?err = fail + unpackOne v' $ \_archProxy retType' ex -> + case testEquality retType retType' of + Just Refl -> do + callPopFrame + returnFromFunction ex + Nothing -> fail $ unwords ["unexpected return type", show retType, show retType'] + + L.RetVoid -> case testEquality retType UnitRepr of + Just Refl -> do + callPopFrame + returnFromFunction (App EmptyApp) + Nothing -> fail $ unwords ["tried to void return from non-void function", show retType] + + -- NB, the symbolic simulator is essentially single-threaded, so fence + -- instructions are no-ops + L.Fence{} -> k + + -- NB, the symbolic simulator is essentially single-threaded, so cmpxchg + -- always succeeds if the expected value is found in memory. + L.CmpXchg _weak _volatile ptr compareValue newValue _syncScope _syncOrderSuccess _syncOrderFail -> + do resTy <- liftMemType' (L.typedType compareValue) + ptr' <- transTypedValue ptr + llvmTypeAsRepr resTy $ \expectTy -> + do cmpVal <- transValue resTy (L.typedValue compareValue) + newVal <- transValue resTy (L.typedValue newValue) + + let a0 = memTypeAlign (llvmDataLayout ?lc) resTy + oldVal <- callLoad resTy expectTy ptr' a0 + cmp <- scalarIntegerCompare L.Ieq oldVal cmpVal + let flag = BaseExpr (LLVMPointerRepr (knownNat @1)) + (BitvectorAsPointerExpr knownNat + (App (BoolToBV knownNat cmp))) + ifte_ cmp + -- success case, write the new value + (callStore resTy ptr' newVal a0) + -- failure case, do nothing + (return ()) + assign_f (StructExpr (Seq.fromList [(resTy,oldVal),(IntType 1,flag)])) + k + + -- NB, the symbolic simulator is essentially single-threaded, so no special + -- actions need to be taken to make operations atomic. We simply execute + -- their straightforward load/modify/store semantics. + L.AtomicRW _volatile op ptr val _syncScope _ordering -> + do valTy <- liftMemType' (L.typedType val) + ptr' <- transTypedValue ptr + case valTy of + IntType _ -> pure () + _ -> fail $ unwords + ["Invalid argument type on atomicrw, expected integer type", show ptr] + llvmTypeAsRepr valTy $ \expectTy -> + do val' <- transValue valTy $ L.typedValue val + let a0 = memTypeAlign (llvmDataLayout ?lc) valTy + oldVal <- callLoad valTy expectTy ptr' a0 + newVal <- atomicRWOp op oldVal val' + callStore valTy ptr' newVal a0 + assign_f oldVal + k + + -- We translate `freeze` instructions by simply passing the argument value + -- through unchanged. This doesn't quite adhere to LLVM's own semantics for + -- this instruction (https://releases.llvm.org/12.0.0/docs/LangRef.html#id323), + -- which state that if the argument is `undef` or `poison`, then `freeze` + -- should return an arbitrary value. We don't currently have the ability to + -- reliably determine whether a given value is `undef` or `poison`, however + -- (see https://github.com/GaloisInc/crucible/issues/366), so for now we + -- settle for a less accurate translation of `freeze`. + L.Freeze x -> do + tp' <- liftMemType' (L.typedType x) + x' <- transValue tp' (L.typedValue x) + assign_f x' + k + + -- unwind, landingpad and resume are all exception-related, which we don't currently + -- support + L.Unwind{} -> unsupported + L.LandingPad{} -> unsupported + L.Resume{} -> unsupported + + -- indirect branch could be supported, but requires some nontrivial work to deal + -- properly with mapping basic-block labels to pointer values. + L.IndirectBr{} -> unsupported + + -- VaArg is uncommonly used and hard to support + L.VaArg{} -> unsupported + + where + liftMemType' = either typeErr return . liftMemType + + typeErr msg = + malformedLLVMModule "Invalid type when translating instruction" + [ fromString (showInstr instr) + , fromString msg + ] + + unsupported = reportError $ App $ StringLit $ UnicodeLiteral $ Text.pack $ + unwords ["unsupported instruction", showInstr instr] + +arithOp :: (?transOpts :: TranslationOptions) => + L.ArithOp -> + MemType -> + LLVMExpr s arch -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +arithOp op (VecType n tp) (explodeVector n -> Just xs) (explodeVector n -> Just ys) = + VecExpr tp <$> sequence (Seq.zipWith (\x y -> arithOp op tp x y) xs ys) + +arithOp op _ x y = + case (asScalar x, asScalar y) of + (Scalar _ ty@(LLVMPointerRepr w) x', + Scalar _ (LLVMPointerRepr w') y') + | Just Refl <- testEquality w PtrWidth + , Just Refl <- testEquality w w' -> + do z <- pointerOp op x' y' + return (BaseExpr ty z) + + | Just Refl <- testEquality w w' -> + do xbv <- pointerAsBitvectorExpr w x' + ybv <- pointerAsBitvectorExpr w y' + z <- intop op w xbv ybv + return (BaseExpr (LLVMPointerRepr w) (BitvectorAsPointerExpr w z)) + + (Scalar _archProxy (FloatRepr fi) x', + Scalar _archPrxy' (FloatRepr fi') y') + | Just Refl <- testEquality fi fi' -> + do ex <- fop fi x' y' + return (BaseExpr (FloatRepr fi) ex) + + _ -> reportError + $ fromString + $ unwords ["binary arithmetic operation on unsupported values", + show x, show y] + + where + fop :: FloatInfoRepr fi -> + Expr LLVM s (FloatType fi) -> + Expr LLVM s (FloatType fi) -> + LLVMGenerator s arch ret (Expr LLVM s (FloatType fi)) + fop fi a b = + case op of + L.FAdd -> + return $ App $ FloatAdd fi RNE a b + L.FSub -> + return $ App $ FloatSub fi RNE a b + L.FMul -> + return $ App $ FloatMul fi RNE a b + L.FDiv -> + return $ App $ FloatDiv fi RNE a b + L.FRem -> do + return $ App $ FloatRem fi a b + _ -> reportError + $ fromString + $ unwords [ "unsupported floating-point arith operation" + , show op, show x, show y + ] + +unaryArithOp :: (?transOpts :: TranslationOptions) => + L.UnaryArithOp -> + MemType -> + LLVMExpr s arch -> + LLVMGenerator s arch ret (LLVMExpr s arch) +unaryArithOp op (VecType n tp) (explodeVector n -> Just xs) = + VecExpr tp <$> sequence (fmap (\x -> unaryArithOp op tp x) xs) + +unaryArithOp op _ x = + case asScalar x of + Scalar _archProxy (FloatRepr fi) x' -> + do ex <- fop fi x' + return (BaseExpr (FloatRepr fi) ex) + + _ -> reportError + $ fromString + $ unwords ["unary arithmetic operation on unsupported value", + show x] + + where + fop :: FloatInfoRepr fi -> + Expr LLVM s (FloatType fi) -> + LLVMGenerator s arch ret (Expr LLVM s (FloatType fi)) + fop fi a = + case op of + L.FNeg -> + return $ App $ FloatNeg fi a + +-- | Generate a call to an LLVM function, without any special +-- handling for debug intrinsics or breakpoints. +callOrdinaryFunction :: + Maybe L.Instr {- ^ The instruction causing this call -} -> + Bool {- ^ Is the function a tail call? -} -> + L.Type {- ^ type of the function to call -} -> + L.Value {- ^ function value to call -} -> + [L.Typed L.Value] {- ^ argument list -} -> + (LLVMExpr s arch -> LLVMGenerator s arch ret ()) {- ^ assignment continuation for return value -} -> + LLVMGenerator s arch ret () +callOrdinaryFunction instr _tailCall fnTy@(L.FunTy lretTy _largTys _varargs) fn args assign_f = do + let err :: String -> a + err = \msg -> malformedLLVMModule "Invalid type in function call" $ + [ fromString msg ] + ++ + maybe [] ((:[]) . fromString . showInstr) instr + + fnTy' <- either err return $ liftMemType (L.PtrTo fnTy) + retTy' <- either err return $ liftRetType lretTy + fn' <- transValue fnTy' fn + args' <- mapM (\v -> transTypedValue v) args + + let ?err = err + unpackArgs args' $ \_archProxy argTypes args'' -> + llvmRetTypeAsRepr retTy' $ \retTy -> + case asScalar fn' of + Scalar _ PtrRepr ptr -> do + memVar <- getMemVar + v <- extensionStmt (LLVM_LoadHandle memVar (Just fnTy) ptr argTypes retTy) + ret <- call v args'' + assign_f (BaseExpr retTy ret) + _ -> fail $ unwords ["unsupported function value", show fn] + +callOrdinaryFunction instr _tailCall fnTy _fn _args _assign_f = + reportError $ App $ StringLit $ UnicodeLiteral $ Text.pack $ unlines $ + [ "[callFunction] Unsupported function type: " ++ show fnTy ] + ++ + maybe [] ( (:[]) . show) instr + + +-- | Generate a call to an LLVM function, generating special support +-- for debugging intrinsics and breakpoint functions. +callFunction :: forall s arch ret. + (?transOpts :: TranslationOptions) => + Set L.Ident {- ^ Set of usable identifiers -} -> + L.Instr {- ^ Source instruction of the call -} -> + Bool {- ^ Is the function a tail call? -} -> + L.Type {- ^ type of the function to call -} -> + L.Value {- ^ function value to call -} -> + [L.Typed L.Value] {- ^ argument list -} -> + (LLVMExpr s arch -> LLVMGenerator s arch ret ()) {- ^ assignment continuation for return value -} -> + LLVMGenerator s arch ret () +callFunction defSet instr tailCall_ fnTy fn args assign_f + + -- Supports LLVM 4-12 + | L.ValSymbol "llvm.dbg.declare" <- fn + , debugIntrinsics ?transOpts = + do mbArgs <- dbgArgs defSet args + case mbArgs of + Right (asScalar -> Scalar _ PtrRepr ptr, lv, di) -> + do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Declare ptr lv di)) + return () + Left msg -> addWarning (Text.pack msg) + _ -> addWarning "Unexpected argument in llvm.dbg.declare" + + -- Supports LLVM 6-12 + | L.ValSymbol "llvm.dbg.addr" <- fn + , debugIntrinsics ?transOpts = + do mbArgs <- dbgArgs defSet args + case mbArgs of + Right (asScalar -> Scalar _ PtrRepr ptr, lv, di) -> + do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Addr ptr lv di)) + return () + Left msg -> addWarning (Text.pack msg) + _ -> addWarning "Unexpected argument in llvm.dbg.addr" + + -- Supports LLVM 6-12 (earlier versions had an extra argument) + | L.ValSymbol "llvm.dbg.value" <- fn + , debugIntrinsics ?transOpts = + do mbArgs <- dbgArgs defSet args + case mbArgs of + Right (asScalar -> Scalar _ repr val, lv, di) -> + do _ <- extensionStmt (LLVM_Debug (LLVM_Dbg_Value repr val lv di)) + return () + Left msg -> addWarning (Text.pack msg) + _ -> addWarning "Unexpected argument in llvm.dbg.value" + + -- Skip calls to other debugging intrinsics. + | L.ValSymbol nm <- fn + , nm `elem` [ "llvm.dbg.label" + , "llvm.dbg.declare" + , "llvm.dbg.addr" + , "llvm.dbg.value" + , "llvm.lifetime.start" + , "llvm.lifetime.start.p0" + , "llvm.lifetime.start.p0i8" + , "llvm.lifetime.end" + , "llvm.lifetime.end.p0" + , "llvm.lifetime.end.p0i8" + , "llvm.invariant.start" + , "llvm.invariant.start.p0i8" + , "llvm.invariant.start.p0" + , "llvm.invariant.end" + , "llvm.invariant.end.p0i8" + , "llvm.invariant.end.p0" + ] = return () + + | L.ValSymbol (L.Symbol nm) <- fn + , testBreakpointFunction nm = do + some_val_args <- mapM (\tv -> typedValueAsCrucibleValue tv) args + case Ctx.fromList some_val_args of + Some val_args -> do + addBreakpointStmt (Text.pack nm) val_args + + | otherwise = callOrdinaryFunction (Just instr) tailCall_ fnTy fn args assign_f + +-- | Match the arguments used by @dbg.addr@, @dbg.declare@, and @dbg.value@. +dbgArgs :: + Set L.Ident {- ^ Set of usable identifiers -} -> + [L.Typed L.Value] {- ^ debug call arguments -} -> + LLVMGenerator s arch ret (Either String (LLVMExpr s arch, L.DILocalVariable, L.DIExpression)) +dbgArgs defSet args = + case args of + [valArg, lvArg, diArg] -> + case valArg of + L.Typed _ (L.ValMd (L.ValMdValue val)) -> + case lvArg of + L.Typed _ (L.ValMd (L.ValMdDebugInfo (L.DebugInfoLocalVariable lv))) -> + case diArg of + L.Typed _ (L.ValMd (L.ValMdDebugInfo (L.DebugInfoExpression di))) -> + let unusableIdents = Set.difference (useTypedVal val) defSet + in if Set.null unusableIdents then + do v <- transTypedValue val + pure (Right (v, lv, di)) + else + do let msg = unwords (["dbg intrinsic def/use violation for:"] ++ + map (show . LPP.ppIdent) (Set.toList unusableIdents)) + pure (Left msg) + _ -> pure (Left ("dbg: argument 3 expected DIExpression, got: " ++ show diArg)) + _ -> pure (Left ("dbg: argument 2 expected local variable metadata, got: " ++ show lvArg)) + _ -> pure (Left ("dbg: argument 1 expected value metadata, got: " ++ show valArg)) + _ -> pure (Left ("dbg: expected 3 arguments, got: " ++ show (length args))) + +typedValueAsCrucibleValue :: + L.Typed L.Value -> + LLVMGenerator s arch ret (Some (Value s)) +typedValueAsCrucibleValue tv = case L.typedValue tv of + L.ValIdent i -> do + m <- use identMap + case Map.lookup i m of + Just (Left (Some r)) ->return $ Some $ RegValue r + Just (Right (Some a)) -> return $ Some $ AtomValue a + Nothing -> reportError $ fromString $ + "Could not find identifier " ++ show i ++ "." + v -> reportError $ fromString $ + "Unsupported breakpoint parameter: " ++ show v ++ "." + + + +-- | Build a switch statement by decomposing it into a linear sequence of branches. +-- FIXME? this could be more efficient if we sort the list and do binary search instead... +buildSwitch :: (1 <= w) + => NatRepr w + -> Expr LLVM s (BVType w) -- ^ The expression to switch on + -> L.BlockLabel -- ^ The label of the current basic block + -> L.BlockLabel -- ^ The label of the default basic block if no other branch applies + -> [(Integer, L.BlockLabel)] -- ^ The switch labels + -> LLVMGenerator s arch ret a +buildSwitch _ _ curr_lab def [] = + definePhiBlock curr_lab def +buildSwitch w ex curr_lab def ((i,l):bs) = do + let test = App $ BVEq w ex $ App $ BVLit w (BV.mkBV w i) + t_id <- newLabel + f_id <- newLabel + defineBlock t_id (definePhiBlock curr_lab l) + defineBlock f_id (buildSwitch w ex curr_lab def bs) + branch test t_id f_id + +-- | Implement the phi-functions along the edge from one LLVM Basic block to another. +definePhiBlock :: L.BlockLabel -- ^ The LLVM source basic block + -> L.BlockLabel -- ^ The LLVM target basic block + -> LLVMGenerator s arch ret a +definePhiBlock l l' = do + bim <- use blockInfoMap + case Map.lookup l' bim of + Nothing -> fail $ unwords ["label not found in label map:", show l'] + Just bi' -> do + -- Collect all the relevant phi functions to evaluate + let phi_funcs = maybe [] toList $ Map.lookup l (block_phi_map bi') + + -- NOTE: We evaluate all the right-hand sides of the phi nodes BEFORE + -- we assign the values to their associated registers. This preserves + -- the expected semantics that phi functions are evaluated in the context + -- of the previous basic block, and prevents unintended register shadowing. + -- Otherwise loop-carried dependencies will sometimes end up with the wrong + -- values. + phiVals <- mapM evalPhi phi_funcs + mapM_ assignPhi phiVals + + -- Now jump to the target code block + jump (block_label bi') + + where evalPhi (ident,tp,v) = do + t_v <- transTypedValue (L.Typed tp v) + return (ident,t_v) + assignPhi (ident,t_v) = do + assignLLVMReg ident t_v + + +-- | Assign a packed LLVM expression into the named LLVM register. +assignLLVMReg + :: L.Ident + -> LLVMExpr s arch + -> LLVMGenerator s arch ret () +assignLLVMReg ident rhs = do + st <- get + let idMap = st^.identMap + case Map.lookup ident idMap of + Just (Left lhs) -> do + doAssign lhs rhs + Just (Right _) -> fail $ "internal: Value cannot be assigned to." + Nothing -> fail $ unwords ["register not found in register map:", show ident] + +-- | Given a register and an expression shape, assign the expressions in the right-hand-side +-- into the register left-hand side. +doAssign :: forall s arch ret. + Some (Reg s) + -> LLVMExpr s arch -- ^ the RHS values to assign + -> LLVMGenerator s arch ret () +doAssign (Some r) (BaseExpr tpr ex) = + case testEquality (typeOfReg r) tpr of + Just Refl -> assignReg r ex + Nothing -> reportError $ fromString $ unwords ["type mismatch when assigning register", show r, show (typeOfReg r) , show tpr] +doAssign (Some r) (StructExpr vs) = do + let ?err = fail + unpackArgs (map snd $ toList vs) $ \_archProxy ctx asgn -> + case testEquality (typeOfReg r) (StructRepr ctx) of + Just Refl -> assignReg r (mkStruct ctx asgn) + Nothing -> reportError $ fromString $ unwords ["type mismatch when assigning structure to register", show r, show (StructRepr ctx)] +doAssign (Some r) (ZeroExpr tp) = do + let ?err = fail + zeroExpand (proxy# :: Proxy# arch) tp $ \_archProxy (tpr :: TypeRepr t) (ex :: Expr LLVM s t) -> + case testEquality (typeOfReg r) tpr of + Just Refl -> assignReg r ex + Nothing -> reportError $ fromString $ "type mismatch when assigning zero value" +doAssign (Some r) (UndefExpr tp) = do + let ?err = fail + undefExpand (proxy# :: Proxy# arch) tp $ \_archProxy (tpr :: TypeRepr t) (ex :: Expr LLVM s t) -> + case testEquality (typeOfReg r) tpr of + Just Refl -> assignReg r ex + Nothing -> reportError $ fromString $ "type mismatch when assigning undef value" +doAssign (Some r) (VecExpr tp vs) = do + let ?err = fail + llvmTypeAsRepr tp $ \tpr -> + unpackVec (proxy# :: Proxy# arch) tpr (toList vs) $ \ex -> + case testEquality (typeOfReg r) (VectorRepr tpr) of + Just Refl -> assignReg r ex + Nothing -> reportError $ fromString $ "type mismatch when assigning vector value" diff --git a/src/Lang/Crucible/LLVM/Translation/Monad.hs b/src/Lang/Crucible/LLVM/Translation/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Monad.hs @@ -0,0 +1,268 @@ +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Monad +-- Description : Translation monad for LLVM and support operations +-- Copyright : (c) Galois, Inc 2018 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +----------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Lang.Crucible.LLVM.Translation.Monad + ( -- * Generator monad + LLVMGenerator + , LLVMGenerator' + , LLVMState(..) + , identMap + , blockInfoMap + , translationWarnings + , functionSymbol + , addWarning + , LLVMTranslationWarning(..) + , IdentMap + , LLVMBlockInfo(..) + , LLVMBlockInfoMap + , buildBlockInfoMap + , initialState + , getMemVar + + -- * Malformed modules + , MalformedLLVMModule(..) + , malformedLLVMModule + , renderMalformedLLVMModule + + -- * LLVMContext + , LLVMContext(..) + , llvmTypeCtx + , mkLLVMContext + + , useTypedVal + ) where + +import Control.Lens hiding (op, (:>), to, from ) +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Strict (MonadState(..)) +import Data.IORef (IORef, modifyIORef) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import Data.Text (Text) + +import qualified Text.LLVM.AST as L + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr as NatRepr +import Data.Parameterized.Some + +import Lang.Crucible.CFG.Generator +import Lang.Crucible.Panic ( panic ) + +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.Extension +import Lang.Crucible.LLVM.MalformedLLVMModule +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.Translation.BlockInfo +import Lang.Crucible.LLVM.Translation.Types +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.Types + +------------------------------------------------------------------------ +-- ** LLVMContext + +-- | Information about the LLVM module. +data LLVMContext arch + = LLVMContext + { -- | Map LLVM symbols to their associated state. + llvmArch :: ArchRepr arch + , llvmPtrWidth :: forall a. (16 <= (ArchWidth arch) => NatRepr (ArchWidth arch) -> a) -> a + , llvmMemVar :: GlobalVar Mem + , _llvmTypeCtx :: TypeContext + -- | For each global variable symbol, compute the set of + -- aliases to that symbol + , llvmGlobalAliases :: Map L.Symbol (Set L.GlobalAlias) + -- | For each function symbol, compute the set of + -- aliases to that symbol + , llvmFunctionAliases :: Map L.Symbol (Set L.GlobalAlias) + } + +llvmTypeCtx :: Simple Lens (LLVMContext arch) TypeContext +llvmTypeCtx = lens _llvmTypeCtx (\s v -> s{ _llvmTypeCtx = v }) + +mkLLVMContext :: GlobalVar Mem + -> L.Module + -> IO (Some LLVMContext) +mkLLVMContext mvar m = do + let (errs, typeCtx) = typeContextFromModule m + unless (null errs) $ + malformedLLVMModule "Failed to construct LLVM type context" errs + let dl = llvmDataLayout typeCtx + + case mkNatRepr (ptrBitwidth dl) of + Some (wptr :: NatRepr wptr) | Just LeqProof <- testLeq (knownNat @16) wptr -> + withPtrWidth wptr $ + do let archRepr = X86Repr wptr -- FIXME! we should select the architecture based on + -- the target triple, but llvm-pretty doesn't capture this + -- currently. + let ctx :: LLVMContext (X86 wptr) + ctx = LLVMContext + { llvmArch = archRepr + , llvmMemVar = mvar + , llvmPtrWidth = \x -> x wptr + , _llvmTypeCtx = typeCtx + , llvmGlobalAliases = mempty -- these are computed later + , llvmFunctionAliases = mempty -- these are computed later + } + return (Some ctx) + _ -> + fail ("Cannot load LLVM bitcode file with illegal pointer width: " ++ show (dl^.ptrSize)) + + +-- | A monad providing state and continuations for translating LLVM expressions +-- to CFGs. +type LLVMGenerator s arch ret a = + (?lc :: TypeContext, HasPtrWidth (ArchWidth arch)) => + Generator LLVM s (LLVMState arch) ret IO a + +-- | @LLVMGenerator@ without the constraint, can be nested further inside monads. +type LLVMGenerator' s arch ret = + Generator LLVM s (LLVMState arch) ret IO + + +-- LLVMState + +getMemVar :: LLVMGenerator s arch reg (GlobalVar Mem) +getMemVar = llvmMemVar . llvmContext <$> get + +-- | Maps identifiers to an associated register or defined expression. +type IdentMap s = Map L.Ident (Either (Some (Reg s)) (Some (Atom s))) + +-- | A warning generated during translation +data LLVMTranslationWarning = + LLVMTranslationWarning + L.Symbol -- ^ Function name in which the warning was generated + Position -- ^ Source position where the warning was generated + Text -- ^ Description of the warning + +data LLVMState arch s + = LLVMState + { -- | Map from identifiers to associated register shape + _identMap :: !(IdentMap s) + , _blockInfoMap :: !(LLVMBlockInfoMap s) + , llvmContext :: LLVMContext arch + , _translationWarnings :: IORef [LLVMTranslationWarning] + , _functionSymbol :: L.Symbol + } + +identMap :: Lens' (LLVMState arch s) (IdentMap s) +identMap = lens _identMap (\s v -> s { _identMap = v }) + +blockInfoMap :: Lens' (LLVMState arch s) (LLVMBlockInfoMap s) +blockInfoMap = lens _blockInfoMap (\s v -> s { _blockInfoMap = v }) + +translationWarnings :: Lens' (LLVMState arch s) (IORef [LLVMTranslationWarning]) +translationWarnings = lens _translationWarnings (\s v -> s { _translationWarnings = v }) + +functionSymbol :: Lens' (LLVMState arch s) L.Symbol +functionSymbol = lens _functionSymbol (\s v -> s{ _functionSymbol = v }) + +addWarning :: Text -> LLVMGenerator s arch ret () +addWarning warn = + do r <- use translationWarnings + s <- use functionSymbol + p <- getPosition + liftIO (modifyIORef r ((LLVMTranslationWarning s p warn):)) + + +-- | Given a list of LLVM formal parameters and a corresponding crucible +-- register assignment, build an IdentMap mapping LLVM identifiers to +-- corresponding crucible registers. +buildIdentMap :: (?lc :: TypeContext, HasPtrWidth wptr) + => [L.Typed L.Ident] + -> Bool -- ^ varargs + -> CtxRepr ctx + -> Ctx.Assignment (Atom s) ctx + -> IdentMap s + -> IdentMap s +buildIdentMap ts True ctx asgn m = + -- Vararg functions are translated as taking a vector of extra arguments + packBase (VectorRepr AnyRepr) ctx asgn $ \_x ctx' asgn' -> + buildIdentMap ts False ctx' asgn' m +buildIdentMap [] _ ctx _ m + | Ctx.null ctx = m + | otherwise = + panic "crucible-llvm:Translation.buildIdentMap" + [ "buildIdentMap: passed arguments do not match LLVM input signature" ] +buildIdentMap (ti:ts) _ ctx asgn m = do + let ty = case liftMemType (L.typedType ti) of + Right t -> t + Left err -> panic "crucible-llvm:Translation.buildIdentMap" + [ "Error attempting to lift type " <> show ti + , show err + ] + packType ty ctx asgn $ \x ctx' asgn' -> + buildIdentMap ts False ctx' asgn' (Map.insert (L.typedValue ti) (Right x) m) + +-- | Build the initial LLVM generator state upon entry to to the entry point of a function. +initialState :: (?lc :: TypeContext, HasPtrWidth wptr) + => L.Define + -> LLVMContext arch + -> CtxRepr args + -> Ctx.Assignment (Atom s) args + -> IORef [LLVMTranslationWarning] + -> LLVMState arch s +initialState d llvmctx args asgn warnRef = + let m = buildIdentMap (reverse (L.defArgs d)) (L.defVarArgs d) args asgn Map.empty in + LLVMState { _identMap = m + , _blockInfoMap = Map.empty + , llvmContext = llvmctx + , _translationWarnings = warnRef + , _functionSymbol = L.defName d + } + +-- | Given an LLVM type and a type context and a register assignment, +-- peel off the rightmost register from the assignment, which is +-- expected to match the given LLVM type. Pass the register and +-- the remaining type and register context to the given continuation. +-- +-- This procedure is used to set up the initial state of the +-- registers at the entry point of a function. +packType :: HasPtrWidth wptr + => MemType + -> CtxRepr ctx + -> Ctx.Assignment (Atom s) ctx + -> (forall ctx'. Some (Atom s) -> CtxRepr ctx' -> Ctx.Assignment (Atom s) ctx' -> a) + -> a +packType tp ctx asgn k = + llvmTypeAsRepr tp $ \repr -> + packBase repr ctx asgn k + +packBase + :: TypeRepr tp + -> CtxRepr ctx + -> Ctx.Assignment (Atom s) ctx + -> (forall ctx'. Some (Atom s) -> CtxRepr ctx' -> Ctx.Assignment (Atom s) ctx' -> a) + -> a +packBase ctp ctx0 asgn k = + case ctx0 of + ctx' Ctx.:> ctp' -> + case testEquality ctp ctp' of + Nothing -> error $ unwords ["crucible type mismatch",show ctp,show ctp'] + Just Refl -> + let asgn' = Ctx.init asgn + idx = Ctx.nextIndex (Ctx.size asgn') + in k (Some (asgn Ctx.! idx)) + ctx' + asgn' + _ -> error "packType: ran out of actual arguments!" diff --git a/src/Lang/Crucible/LLVM/Translation/Options.hs b/src/Lang/Crucible/LLVM/Translation/Options.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Options.hs @@ -0,0 +1,55 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Translation.Options +-- Description : Definition of options that can be tweaked during LLVM translation +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +module Lang.Crucible.LLVM.Translation.Options + ( TranslationOptions(..) + , defaultTranslationOptions + , debugIntrinsicsTranslationOptions + ) where + +-- | This datatype encodes a variety of tweakable settings that apply during +-- LLVM translation. +data TranslationOptions + = TranslationOptions + { debugIntrinsics :: !Bool + -- ^ Should we translate @llvm.dbg@ intrinsic statements? The upside to + -- translating them is that they encode debugging information about a + -- program that can be useful for external clients. The downside is + -- that they can bloat the size of translated programs, despite being + -- no-ops during simulation. + , laxArith :: !Bool + -- ^ Should we omit proof obligations related to arithmetic overflow + -- and similar assertions? + , optLoopMerge :: !Bool + -- ^ Should we insert merge blocks in loops with early exits (i.e. breaks + -- or returns)? This may improve simulation performance. + } + +-- | The default translation options: +-- +-- * Do not translate @llvm.dbg@ intrinsic statements +-- +-- * Do not produce proof obligations for arithmetic-related assertions. +-- +-- * Do not insert merge blocks in loops with early exits. +defaultTranslationOptions :: TranslationOptions +defaultTranslationOptions = + TranslationOptions + { debugIntrinsics = False + , laxArith = False + , optLoopMerge = False + } + +-- | Like 'defaultTranslationOptions', but @llvm.dbg@ intrinsic statements are +-- translated. +debugIntrinsicsTranslationOptions :: TranslationOptions +debugIntrinsicsTranslationOptions = + defaultTranslationOptions + { debugIntrinsics = True + } diff --git a/src/Lang/Crucible/LLVM/Translation/Types.hs b/src/Lang/Crucible/LLVM/Translation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Translation/Types.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Translation.Types +-- Description : Translation of LLVM AST into Crucible control-flow graph +-- Copyright : (c) Galois, Inc 2014-2015 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +-- +-- +-- This module defines the translation from LLVM types to Crucible types. +-- +-- The translation of the LLVM types themselves is not so difficult; +-- however, navigating the fact that Crucible expressions are strongly +-- typed at the Haskell level, whereas the LLVM types are not makes for +-- some slightly strange programming idioms. In particular, all the +-- functions that do the type translation are written in a polymorphic +-- continuation-passing style. +---------------------------------------------------------------------- + +module Lang.Crucible.LLVM.Translation.Types +( VarArgs +, varArgsRepr +, llvmTypesAsCtx +, llvmTypeAsRepr +, llvmRetTypeAsRepr +, llvmDeclToFunHandleRepr +, llvmDeclToFunHandleRepr' +, LLVMPointerType +, pattern PtrWidth +, pattern LLVMPointerRepr +, declareFromDefine +, allModuleDeclares +, liftMemType +, liftRetType +, liftDeclare +) where + +import qualified Control.Monad.Fail as Fail +import Data.Foldable +import Data.String + +import qualified Text.LLVM.AST as L +import Prettyprinter + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some + + +import Lang.Crucible.Panic(panic) +import Lang.Crucible.Types + +import Lang.Crucible.LLVM.MemModel.Pointer +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.MalformedLLVMModule +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP +import Lang.Crucible.LLVM.TypeContext as TyCtx + + + +type VarArgs = VectorType AnyType + +varArgsRepr :: TypeRepr VarArgs +varArgsRepr = VectorRepr AnyRepr + +------------------------------------------------------------------------ +-- LLVM AST utilities + +declareFromDefine :: L.Define -> L.Declare +declareFromDefine d = + L.Declare { L.decLinkage = L.defLinkage d + , L.decVisibility = L.defVisibility d + , L.decRetType = L.defRetType d + , L.decName = L.defName d + , L.decArgs = L.typedType <$> L.defArgs d + , L.decVarArgs = L.defVarArgs d + , L.decAttrs = L.defAttrs d + , L.decComdat = mempty + } + +-- | Return all declarations derived from both external symbols and +-- internal definitions. +allModuleDeclares :: L.Module -> [L.Declare] +allModuleDeclares m = L.modDeclares m ++ def_decls + where def_decls = declareFromDefine <$> L.modDefines m + +----------------------------------------------------------------------------------------- +-- Type translations + +-- | Translate a list of LLVM expressions into a crucible type context, +-- which is passed into the given continuation. +llvmTypesAsCtx :: forall a wptr + . HasPtrWidth wptr + => [MemType] + -> (forall ctx. CtxRepr ctx -> a) + -> a +llvmTypesAsCtx xs f = go (concatMap (toList . llvmTypeToRepr) xs) Ctx.empty + where go :: forall ctx. [Some TypeRepr] -> CtxRepr ctx -> a + go [] ctx = f ctx + go (Some tp:tps) ctx = go tps (ctx Ctx.:> tp) + +-- | Translate an LLVM type into a crucible type, which is passed into +-- the given continuation +llvmTypeAsRepr :: forall a wptr + . HasPtrWidth wptr + => MemType + -> (forall tp. TypeRepr tp -> a) + -> a +llvmTypeAsRepr xs f = go (llvmTypeToRepr xs) + where go :: Maybe (Some TypeRepr) -> a + go Nothing = f UnitRepr + go (Just (Some x)) = f x + +-- | Translate an LLVM return type into a crucible type, which is passed into +-- the given continuation +llvmRetTypeAsRepr :: forall a wptr + . HasPtrWidth wptr + => Maybe MemType + -> (forall tp. TypeRepr tp -> a) + -> a +llvmRetTypeAsRepr Nothing f = f UnitRepr +llvmRetTypeAsRepr (Just tp) f = llvmTypeAsRepr tp f + +-- | Actually perform the type translation +llvmTypeToRepr :: HasPtrWidth wptr => MemType -> Maybe (Some TypeRepr) +llvmTypeToRepr (ArrayType _ tp) = Just $ llvmTypeAsRepr tp (\t -> Some (VectorRepr t)) +llvmTypeToRepr (VecType _ tp) = Just $ llvmTypeAsRepr tp (\t-> Some (VectorRepr t)) +llvmTypeToRepr (StructType si) = Just $ llvmTypesAsCtx tps (\ts -> Some (StructRepr ts)) + where tps = map fiType $ toList $ siFields si +llvmTypeToRepr (PtrType _) = Just $ Some (LLVMPointerRepr PtrWidth) +llvmTypeToRepr PtrOpaqueType = Just $ Some (LLVMPointerRepr PtrWidth) +llvmTypeToRepr FloatType = Just $ Some (FloatRepr SingleFloatRepr) +llvmTypeToRepr DoubleType = Just $ Some (FloatRepr DoubleFloatRepr) +llvmTypeToRepr X86_FP80Type = Just $ Some (FloatRepr X86_80FloatRepr) +llvmTypeToRepr MetadataType = Nothing +llvmTypeToRepr (IntType n) = + case mkNatRepr n of + Some w | Just LeqProof <- isPosNat w -> Just $ Some (LLVMPointerRepr w) + _ -> panic "Translation.Types.llvmTypeToRepr" + [" *** invalid integer width " ++ show n] + +-- | Compute the function Crucible function signature +-- that corresponds to the given LLVM function declaration. +llvmDeclToFunHandleRepr + :: HasPtrWidth wptr + => FunDecl + -> (forall args ret. CtxRepr args -> TypeRepr ret -> a) + -> a +llvmDeclToFunHandleRepr decl k = + llvmTypesAsCtx (fdArgTypes decl) $ \args -> + llvmRetTypeAsRepr (fdRetType decl) $ \ret -> + if fdVarArgs decl then + k (args Ctx.:> varArgsRepr) ret + else + k args ret + + +llvmDeclToFunHandleRepr' :: + (?lc :: TypeContext, HasPtrWidth wptr, Fail.MonadFail m) => + L.Declare -> + (forall args ret. CtxRepr args -> TypeRepr ret -> m a) -> + m a +llvmDeclToFunHandleRepr' decl k = + case liftDeclare decl of + Left msg -> + malformedLLVMModule + ( "Invalid declaration for:" <+> fromString (show (L.decName decl)) ) + [ fromString (show (LPP.ppDeclare decl)) + , fromString msg + ] + + Right fd -> llvmDeclToFunHandleRepr fd k diff --git a/src/Lang/Crucible/LLVM/TypeContext.hs b/src/Lang/Crucible/LLVM/TypeContext.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/TypeContext.hs @@ -0,0 +1,286 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.TypeContext +-- Description : Provides simulator type information and conversions. +-- Copyright : (c) Galois, Inc 2011-2018 +-- License : BSD3 +-- Maintainer : Joe Hendrix +-- Stability : provisional +-- +-- This module provides functionality for querying simulator type +-- information in a module, and converting llvm-pretty types into +-- simulator types. +------------------------------------------------------------------------ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Lang.Crucible.LLVM.TypeContext + ( -- * LLVMContext + TypeContext + , mkTypeContext + , typeContextFromModule + , llvmDataLayout + , llvmMetadataMap + , AliasMap + , llvmAliasMap + -- * LLVMContext query functions. + , compatMemTypes + , compatRetTypes + , compatMemTypeLists + , lookupAlias + , lookupMetadata + , liftType + , liftMemType + , liftRetType + , liftDeclare + , asMemType + ) where + +import Control.Lens +import Control.Monad +import Control.Monad.Except (MonadError(..)) +import Control.Monad.State (State, runState, modify, gets) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as V +import qualified Text.LLVM as L +import qualified Text.LLVM.DebugUtils as L +import Prettyprinter +import Data.IntMap (IntMap) + +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.DataLayout +import qualified Lang.Crucible.LLVM.PrettyPrint as LPP + +data IdentStatus + = Resolved SymType + | Active + | Pending L.Type + +data TCState = TCS { tcsDataLayout :: DataLayout + , tcsMap :: Map Ident IdentStatus + -- | Set of types encountered that are not supported by + -- the + , tcsUnsupported :: Set L.Type + , tcsUnresolvable :: Set Ident + } + +runTC :: DataLayout + -> Map Ident IdentStatus + -> TC a + -> ([Doc ann], a) +runTC pdl initMap m = over _1 tcsErrors . view swapped $ runState m tcs0 + where tcs0 = TCS { tcsDataLayout = pdl + , tcsMap = initMap + , tcsUnsupported = Set.empty + , tcsUnresolvable = Set.empty + } + +tcsErrors :: TCState -> [Doc ann] +tcsErrors tcs = (ppUnsupported <$> Set.toList (tcsUnsupported tcs)) + ++ (ppUnresolvable <$> Set.toList (tcsUnresolvable tcs)) + where ppUnsupported tp = pretty "Unsupported type:" <+> viaShow (LPP.ppType tp) + ppUnresolvable i = pretty "Could not resolve identifier:" <+> viaShow (LPP.ppIdent i) + -- TODO: update if llvm-pretty switches to prettyprinter + +-- | Type lifter contains types that could not be parsed. +type TC = State TCState + +recordUnsupported :: L.Type -> TC () +recordUnsupported tp = modify fn + where fn tcs = tcs { tcsUnsupported = Set.insert tp (tcsUnsupported tcs) } + +-- | Returns the type bound to an identifier. +tcIdent :: Ident -> TC SymType +tcIdent i = do + im <- gets tcsMap + let retUnsupported = tp <$ modify fn + where tp = UnsupportedType (L.Alias i) + fn tcs = tcs { tcsUnresolvable = Set.insert i (tcsUnresolvable tcs) } + case Map.lookup i im of + Nothing -> retUnsupported + Just (Resolved tp) -> return tp + Just Active -> retUnsupported + Just (Pending tp) -> do + modify (ins Active) + stp <- tcType tp + stp <$ modify (ins (Resolved stp)) + where ins v tcs = tcs { tcsMap = Map.insert i v (tcsMap tcs) } + +resolveMemType :: SymType -> TC (Maybe MemType) +resolveMemType = resolve + where resolve (MemType mt) = return (Just mt) + resolve (Alias i) = resolve =<< tcIdent i + resolve _ = return Nothing + +resolveRetType :: SymType -> TC (Maybe RetType) +resolveRetType = resolve + where resolve (MemType mt) = return (Just (Just mt)) + resolve (Alias i) = resolve =<< tcIdent i + resolve VoidType = return (Just Nothing) + resolve _ = return Nothing + +tcMemType :: L.Type -> TC (Maybe MemType) +tcMemType = resolveMemType <=< tcType + +tcType :: L.Type -> TC SymType +tcType tp0 = do + let badType = UnsupportedType tp0 <$ recordUnsupported tp0 + let maybeApp :: (a -> MemType) -> TC (Maybe a) -> TC SymType + maybeApp f mmr = maybe badType (return . MemType . f) =<< mmr + case tp0 of + L.PrimType pt -> + case pt of + L.FloatType ft -> do + case ft of + L.Float -> return $ MemType FloatType + L.Double -> return $ MemType DoubleType + L.X86_fp80 -> return $ MemType X86_FP80Type + _ -> badType + L.Integer w -> return $ MemType $ IntType (fromIntegral w) + L.Void -> return VoidType + L.Metadata -> return $ MemType MetadataType + _ -> badType + L.Alias i -> return (Alias i) + L.Array n etp -> maybeApp (ArrayType (fromIntegral n)) $ tcMemType etp + L.FunTy res args va -> do + mrt <- resolveRetType =<< tcType res + margs <- traverse tcMemType args + maybe badType (return . FunType) $ + FunDecl <$> mrt <*> sequence margs <*> pure va + L.PtrTo tp -> (MemType . PtrType) <$> tcType tp + L.PtrOpaque -> return $ MemType PtrOpaqueType + L.Struct tpl -> maybeApp StructType $ tcStruct False tpl + L.PackedStruct tpl -> maybeApp StructType $ tcStruct True tpl + L.Vector n etp -> maybeApp (VecType (fromIntegral n)) $ tcMemType etp + L.Opaque -> return OpaqueType + +-- | Constructs a function for obtaining target-specific size/alignment +-- information about structs. The function produced corresponds to the +-- StructLayout object constructor in TargetData.cpp. +tcStruct :: Bool -> [L.Type] -> TC (Maybe StructInfo) +tcStruct packed fldTys = do + pdl <- gets tcsDataLayout + fieldMemTys <- traverse tcMemType fldTys + return (mkStructInfo pdl packed <$> sequence fieldMemTys) + + +type AliasMap = Map Ident SymType +type MetadataMap = IntMap L.ValMd + +-- | Provides information about the types in an LLVM bitcode file. +data TypeContext = TypeContext + { llvmDataLayout :: DataLayout + , llvmMetadataMap :: MetadataMap + , llvmAliasMap :: AliasMap + } + +instance Show TypeContext where + show = show . ppTypeContext + +ppTypeContext :: TypeContext -> Doc ann +ppTypeContext lc = + vcat (ppAlias <$> Map.toList (llvmAliasMap lc)) + where ppAlias (i,tp) = ppIdent i <+> equals <+> ppSymType tp + +lookupAlias :: (?lc :: TypeContext, MonadError String m) => Ident -> m SymType +lookupAlias i = + case llvmAliasMap ?lc ^. at i of + Just stp -> return stp + Nothing -> throwError $ unwords ["Unknown type alias", show i] + +lookupMetadata :: (?lc :: TypeContext) => Int -> Maybe L.ValMd +lookupMetadata x = view (at x) (llvmMetadataMap ?lc) + +-- | If argument corresponds to a @MemType@ possibly via aliases, +-- then return it. Otherwise, returns @Nothing@. +asMemType :: (?lc :: TypeContext, MonadError String m) => SymType -> m MemType +asMemType (MemType mt) = return mt +asMemType (Alias i) = asMemType =<< lookupAlias i +asMemType stp = throwError (unlines $ ["Expected memory type", show stp]) + +-- | If argument corresponds to a @RetType@ possibly via aliases, +-- then return it. Otherwise, returns @Nothing@. +asRetType :: (?lc :: TypeContext, MonadError String m) => SymType -> m RetType +asRetType (MemType mt) = return (Just mt) +asRetType VoidType = return Nothing +asRetType (Alias i) = asRetType =<< lookupAlias i +asRetType stp = throwError (unlines $ ["Expected return type", show stp]) + +-- | Creates an LLVMContext from a parsed data layout and lists of types. +-- Errors reported in first argument. +mkTypeContext :: DataLayout -> MetadataMap -> [L.TypeDecl] -> ([Doc ann], TypeContext) +mkTypeContext dl mdMap decls = + let tps = Map.fromList [ (L.typeName d, L.typeValue d) | d <- decls ] in + runTC dl (Pending <$> tps) $ + do aliases <- traverse tcType tps + pure (TypeContext dl mdMap aliases) + +-- | Utility function to creates an LLVMContext directly from a model. +typeContextFromModule :: L.Module -> ([Doc ann], TypeContext) +typeContextFromModule mdl = mkTypeContext dl (L.mkMdMap mdl) (L.modTypes mdl) + where dl = parseDataLayout $ L.modDataLayout mdl + +liftType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m SymType +liftType tp | null edocs = return stp + | otherwise = throwError $ unlines (map show edocs) + where m0 = Resolved <$> llvmAliasMap ?lc + (edocs,stp) = runTC (llvmDataLayout ?lc) m0 $ tcType tp + +liftMemType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m MemType +liftMemType tp = asMemType =<< liftType tp + +liftRetType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m RetType +liftRetType tp = asRetType =<< liftType tp + +liftDeclare :: (?lc::TypeContext, MonadError String m) => L.Declare -> m FunDecl +liftDeclare decl = + do args <- traverse liftMemType (L.decArgs decl) + ret <- liftRetType (L.decRetType decl) + return $ FunDecl + { fdRetType = ret + , fdArgTypes = args + , fdVarArgs = L.decVarArgs decl + } + +compatStructInfo :: StructInfo -> StructInfo -> Bool +compatStructInfo x y = + siIsPacked x == siIsPacked y && + compatMemTypeVectors (siFieldTypes x) (siFieldTypes y) + +-- | Returns true if types are bit-level compatible. +-- +compatMemTypes :: MemType -> MemType -> Bool +compatMemTypes x0 y0 = + case (x0, y0) of + (IntType x, IntType y) -> x == y + (FloatType, FloatType) -> True + (DoubleType, DoubleType) -> True + (PtrType{}, PtrType{}) -> True + (PtrOpaqueType, PtrOpaqueType) -> True + (ArrayType xn xt, ArrayType yn yt) -> + xn == yn && xt `compatMemTypes` yt + (VecType xn xt, VecType yn yt) -> + xn == yn && xt `compatMemTypes` yt + (StructType x, StructType y) -> x `compatStructInfo` y + _ -> False + +compatRetTypes :: RetType -> RetType -> Bool +compatRetTypes Nothing Nothing = True +compatRetTypes (Just x) (Just y) = compatMemTypes x y +compatRetTypes _ _ = False + +compatMemTypeLists :: [MemType] -> [MemType] -> Bool +compatMemTypeLists [] [] = True +compatMemTypeLists (x:xl) (y:yl) = + compatMemTypes x y && compatMemTypeLists xl yl +compatMemTypeLists _ _ = False + +compatMemTypeVectors :: V.Vector MemType -> V.Vector MemType -> Bool +compatMemTypeVectors x y = + V.length x == V.length y && + allOf traverse (uncurry compatMemTypes) (V.zip x y) diff --git a/src/Lang/Crucible/LLVM/Types.hs b/src/Lang/Crucible/LLVM/Types.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Types.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------- +-- | +-- Module : Lang.Crucible.LLVM.Types +-- Description : Crucible type definitions related to LLVM +-- Copyright : (c) Galois, Inc 2015-2016 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +module Lang.Crucible.LLVM.Types + ( Mem + , memRepr + , LLVMPointerType + , LLVMPtr + , pattern LLVMPointerRepr + , pattern PtrRepr + , pattern SizeT + , pattern SSizeT + , withPtrWidth + , HasPtrWidth + , pattern PtrWidth + , GlobalSymbol(..) + , globalSymbolName + ) where + +import GHC.TypeNats +import Data.Typeable + +import Data.Parameterized.Context + +import qualified Text.LLVM.AST as L + +import Lang.Crucible.Simulator.RegValue +import Lang.Crucible.Types + +newtype GlobalSymbol = GlobalSymbol L.Symbol + deriving (Typeable, Eq, Ord, Show) + +globalSymbolName :: GlobalSymbol -> String +globalSymbolName (GlobalSymbol (L.Symbol nm)) = nm + +-- | The 'CrucibleType' of an LLVM memory. @'RegValue' sym 'Mem'@ is +-- implemented as @'MemImpl' sym@. +type Mem = IntrinsicType "LLVM_memory" EmptyCtx + +memRepr :: TypeRepr Mem +memRepr = knownRepr + +-- | This constraint captures the idea that there is a distinguished +-- pointer width in scope which is appropriate according to the C +-- notion of pointer, and object size. In particular, it must be at +-- least 16-bits wide (as required for the @size_t@ type). +type HasPtrWidth w = (1 <= w, 16 <= w, ?ptrWidth :: NatRepr w) + +pattern PtrWidth :: HasPtrWidth w => w ~ w' => NatRepr w' +pattern PtrWidth <- (testEquality ?ptrWidth -> Just Refl) + where PtrWidth = ?ptrWidth + +withPtrWidth :: forall w a. (16 <= w) => NatRepr w -> (HasPtrWidth w => a) -> a +withPtrWidth w a = + case leqTrans (LeqProof :: LeqProof 1 16) (LeqProof :: LeqProof 16 w) of + LeqProof -> let ?ptrWidth = w in a + +-- | Crucible type of pointers/bitvector values of width @w@. +type LLVMPointerType w = IntrinsicType "LLVM_pointer" (EmptyCtx ::> BVType w) + +-- | Symbolic LLVM pointer or bitvector values of width @w@. +type LLVMPtr sym w = RegValue sym (LLVMPointerType w) + +-- | This pattern synonym makes it easy to build and destruct runtime +-- representatives of @'LLVMPointerType' w@. +pattern LLVMPointerRepr :: () => (1 <= w, ty ~ LLVMPointerType w) => NatRepr w -> TypeRepr ty +pattern LLVMPointerRepr w <- IntrinsicRepr (testEquality (knownSymbol :: SymbolRepr "LLVM_pointer") -> Just Refl) + (Empty :> BVRepr w) + where + LLVMPointerRepr w = IntrinsicRepr knownSymbol (Empty :> BVRepr w) + +-- | This pattern creates/matches against the TypeRepr for LLVM pointer values +-- that are of the distinguished pointer width. +pattern PtrRepr :: HasPtrWidth wptr => (ty ~ LLVMPointerType wptr) => TypeRepr ty +pattern PtrRepr = LLVMPointerRepr PtrWidth + +-- | This pattern creates/matches against the TypeRepr for raw bitvector values +-- that are of the distinguished pointer width. +pattern SizeT :: HasPtrWidth wptr => (ty ~ BVType wptr) => TypeRepr ty +pattern SizeT = BVRepr PtrWidth + +-- | This pattern creates/matches against the TypeRepr for raw signed bitvector values +-- that are of the distinguished pointer width. +pattern SSizeT :: HasPtrWidth wptr => (ty ~ BVType wptr) => TypeRepr ty +pattern SSizeT = BVRepr PtrWidth diff --git a/src/Lang/Crucible/LLVM/Utils.hs b/src/Lang/Crucible/LLVM/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Utils.hs @@ -0,0 +1,15 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.Utils +-- Description : Miscellaneous utility functions. +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Maintainer : Rob Dockins +-- Stability : provisional +------------------------------------------------------------------------ +module Lang.Crucible.LLVM.Utils (applyUnless) where + +-- | If the first argument is 'False', apply the second argument to the third. +-- Otherwise, simply return the third argument. +applyUnless :: Applicative f => Bool -> (a -> f a) -> a -> f a +applyUnless b f x = if b then pure x else f x diff --git a/test/MemSetup.hs b/test/MemSetup.hs new file mode 100644 --- /dev/null +++ b/test/MemSetup.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module MemSetup + ( + withInitializedMemory + ) + where + +import Control.Lens ( (^.) ) +import Data.Parameterized.NatRepr +import Data.Parameterized.Nonce +import Data.Parameterized.Some +import qualified Text.LLVM.AST as L + +import qualified What4.Expr as WE + +import qualified Lang.Crucible.Backend as CB +import qualified Lang.Crucible.Backend.Simple as CBS +import Lang.Crucible.FunctionHandle ( withHandleAllocator, HandleAllocator ) + +import qualified Lang.Crucible.LLVM.MemModel as LLVMMem +import Lang.Crucible.LLVM.TypeContext + +import qualified Lang.Crucible.LLVM.Extension as LLVME +import qualified Lang.Crucible.LLVM.Globals as LLVMG +import qualified Lang.Crucible.LLVM.MemModel as LLVMM +import qualified Lang.Crucible.LLVM.Translation as LLVMTr + + +-- | Call 'initializeMemory' and get the result +withInitializedMemory :: forall a. L.Module + -> (forall wptr sym. ( ?lc :: TypeContext + , LLVMMem.HasPtrWidth wptr + , CB.IsSymInterface sym + , LLVMMem.HasLLVMAnn sym + , ?memOpts :: LLVMMem.MemOptions + ) + => LLVMMem.MemImpl sym + -> IO a) + -> IO a +withInitializedMemory mod' action = + withLLVMCtx mod' $ \(ctx :: LLVMTr.LLVMContext arch) sym -> + action @(LLVME.ArchWidth arch) =<< LLVMG.initializeAllMemory sym ctx mod' + + +-- | Create an LLVM context from a module and make some assertions about it. +withLLVMCtx :: forall a. L.Module + -> (forall arch sym bak. + ( ?lc :: TypeContext + , LLVMM.HasPtrWidth (LLVME.ArchWidth arch) + , CB.IsSymBackend sym bak + , LLVMMem.HasLLVMAnn sym + , ?memOpts :: LLVMMem.MemOptions + ) + => LLVMTr.LLVMContext arch + -> bak + -> IO a) + -> IO a +withLLVMCtx mod' action = + let -- This is a separate function because we need to use the scoped type variable + -- @s@ in the binding of @sym@, which is difficult to do inline. + with :: forall s. NonceGenerator IO s -> HandleAllocator -> IO a + with nonceGen halloc = do + sym <- WE.newExprBuilder WE.FloatRealRepr WE.EmptyExprBuilderState nonceGen + bak <- CBS.newSimpleBackend sym + let ?memOpts = LLVMMem.defaultMemOptions + let ?transOpts = LLVMTr.defaultTranslationOptions + memVar <- LLVMM.mkMemVar "test_llvm_memory" halloc + Some mtrans <- LLVMTr.translateModule halloc memVar mod' + let ctx = mtrans ^. LLVMTr.transContext + case LLVMTr.llvmArch ctx of { LLVME.X86Repr width -> + case assertLeq (knownNat @1) width of { LeqProof -> + case assertLeq (knownNat @16) width of { LeqProof -> do + let ?ptrWidth = width + let ?lc = LLVMTr._llvmTypeCtx ctx + let ?recordLLVMAnnotation = \_ _ _ -> pure () + action ctx bak + }}} + in withIONonceGenerator $ \nonceGen -> + withHandleAllocator $ \halloc -> with nonceGen halloc + + +assertLeq :: forall m n . NatRepr m -> NatRepr n -> LeqProof m n +assertLeq m n = + case testLeq m n of + Just LeqProof -> LeqProof + Nothing -> error $ "No LeqProof for " ++ show m ++ " and " ++ show n diff --git a/test/TestFunctions.hs b/test/TestFunctions.hs new file mode 100644 --- /dev/null +++ b/test/TestFunctions.hs @@ -0,0 +1,79 @@ +module TestFunctions + ( + functionTests + ) +where + +import qualified Data.Map.Strict as Map + +import qualified Test.Tasty as T +import Test.Tasty.HUnit ( testCase, (@=?) ) + +import qualified Text.LLVM.AST as L + +import qualified Lang.Crucible.LLVM.MemModel as LLVMMem + +import MemSetup ( withInitializedMemory ) + + +functionTests :: T.TestTree +functionTests = + T.testGroup "Functions" $ + + -- The following ensures that Crucible treats aliases to functions properly + + let alias = L.GlobalAlias + { L.aliasLinkage = Nothing + , L.aliasVisibility = Nothing + , L.aliasName = L.Symbol "aliasName" + , L.aliasType = + L.FunTy + (L.PrimType L.Void) + [ L.PtrTo (L.Alias (L.Ident "class.std::cls")) ] + False + , L.aliasTarget = + L.ValSymbol (L.Symbol "defName") + } + + def = L.Define + { L.defLinkage = Just L.WeakODR + , L.defVisibility = Nothing + , L.defRetType = L.PrimType L.Void + , L.defName = L.Symbol "defName" + , L.defArgs = + [ L.Typed + { L.typedType = L.PtrTo (L.Alias (L.Ident "class.std::cls")) + , L.typedValue = L.Ident "0" + } + ] + , L.defVarArgs = False + , L.defAttrs = [] + , L.defSection = Nothing + , L.defGC = Nothing + , L.defBody = + [ L.BasicBlock + { L.bbLabel = Just (L.Anon 1) + , L.bbStmts = + [ L.Result + (L.Ident "2") + (L.Alloca + (L.PtrTo + (L.Alias (L.Ident "class.std::cls"))) Nothing (Just 8)) + [] + , L.Effect L.RetVoid [] + ] + } + ] + , L.defMetadata = mempty + , L.defComdat = Nothing + } + in [ testCase "initializeMemory (functions)" $ + let mod' = L.emptyModule { L.modDefines = [def] + , L.modAliases = [alias] + } + inMap k = (Just () @=?) . fmap (const ()) . Map.lookup k + in withInitializedMemory mod' $ \memImpl -> + inMap + (L.Symbol "aliasName") + (LLVMMem.memImplGlobalMap memImpl) + ] diff --git a/test/TestGlobals.hs b/test/TestGlobals.hs new file mode 100644 --- /dev/null +++ b/test/TestGlobals.hs @@ -0,0 +1,79 @@ +module TestGlobals + ( + globalTests + ) + where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import qualified Test.Tasty as T +import Test.Tasty.HUnit ( testCase, (@=?) ) + +import qualified Text.LLVM.AST as L + +import qualified Lang.Crucible.LLVM.MemModel as LLVMMem +import Lang.Crucible.LLVM.Translation.Aliases + +import MemSetup ( withInitializedMemory ) + + +globalTests :: T.TestTree +globalTests = + T.testGroup "Global Aliases" $ concat + [ + ------------- Handling of global aliases + + -- It would be nice to have access to the Arbitrary instances for L.AST from + -- llvm-pretty-bc-parser here. + let mkGlobal name = L.Global (L.Symbol name) L.emptyGlobalAttrs L.Opaque Nothing Nothing Map.empty + mkAlias name global = L.GlobalAlias { L.aliasLinkage = Nothing + , L.aliasVisibility = Nothing + , L.aliasName = L.Symbol name + , L.aliasType = L.Opaque + , L.aliasTarget = L.ValSymbol (L.Symbol global) + } + mkModule as gs = L.emptyModule { L.modGlobals = gs + , L.modAliases = as + } + in + [ testCase "globalAliases: empty module" $ + withInitializedMemory (mkModule [] []) $ \_ -> + Map.empty @=? globalAliases L.emptyModule + + , testCase "globalAliases: singletons, aliased" $ + let g = mkGlobal "g" + a = mkAlias "a" "g" + in withInitializedMemory (mkModule [] []) $ \_ -> + Map.singleton (L.globalSym g) (Set.singleton a) @=? globalAliases (mkModule [a] [g]) + + , testCase "globalAliases: two aliases" $ + let g = mkGlobal "g" + a1 = mkAlias "a1" "g" + a2 = mkAlias "a2" "g" + in withInitializedMemory (mkModule [] []) $ \_ -> + Map.singleton (L.globalSym g) (Set.fromList [a1, a2]) @=? globalAliases (mkModule [a1, a2] [g]) + ] + + , -- The following test ensures that SAW treats global aliases properly in that + -- they are present in the @Map@ of globals after initializing the memory. + + let t = L.PrimType (L.Integer 2) + mkGlobal name = L.Global (L.Symbol name) L.emptyGlobalAttrs t Nothing Nothing Map.empty + mkAlias name global = L.GlobalAlias { L.aliasLinkage = Nothing + , L.aliasVisibility = Nothing + , L.aliasName = L.Symbol name + , L.aliasType = t + , L.aliasTarget = L.ValSymbol (L.Symbol global) + } + mkModule as gs = L.emptyModule { L.modGlobals = gs + , L.modAliases = as + } + in [ testCase "initializeMemory" $ + let mod' = mkModule [mkAlias "a" "g"] [mkGlobal "g"] + inMap k = (Just () @=?) . fmap (const ()) . Map.lookup k + in withInitializedMemory mod' $ \result -> + inMap (L.Symbol "a") (LLVMMem.memImplGlobalMap result) + ] + + ] diff --git a/test/TestMemory.hs b/test/TestMemory.hs new file mode 100644 --- /dev/null +++ b/test/TestMemory.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module TestMemory + ( + memoryTests + ) +where + +import Control.Lens ( (^.), _1, _2 ) +import Control.Monad ( foldM, forM_, void ) +import Data.Foldable ( foldlM ) +import qualified Data.Vector as V + +import qualified Test.Tasty as T +import Test.Tasty.HUnit ( testCase, (@=?), assertFailure ) + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Context as Ctx +import Data.Parameterized.NatRepr ( knownNat ) +import Data.Parameterized.Nonce ( withIONonceGenerator ) +import qualified What4.Expr as WE +import qualified What4.Expr.Builder as WE +import qualified What4.Config as What4 +import qualified What4.Interface as What4 +import What4.ProblemFeatures ( noFeatures ) +import qualified What4.Protocol.Online as W4O +import qualified What4.SatResult as W4Sat + +import qualified Lang.Crucible.Backend as CB +import qualified Lang.Crucible.Backend.Online as CBO +import qualified Lang.Crucible.Simulator as CS +import qualified Lang.Crucible.Types as Crucible + +import Lang.Crucible.LLVM.DataLayout ( noAlignment ) +import qualified Lang.Crucible.LLVM.DataLayout as LLVMD +import Lang.Crucible.LLVM.MemModel ( doLoad, doStore, projectLLVM_bv, ptrAdd ) +import qualified Lang.Crucible.LLVM.MemModel as LLVMMem +import qualified Lang.Crucible.LLVM.MemModel.Generic as LLVMMemG + + +memoryTests :: T.TestTree +memoryTests = T.testGroup "Memory" + [ + testArrayStride + , testMemAllocs + , testMemWritesIndexed + , testMemArrayWithConstants + , testMemArray + , testPointerStore + , testStructStore + , testMemArrayCopy + , testMemArraySet + , testMemInvalidate + ] + +withMem :: + LLVMD.EndianForm -> + (forall bak sym scope solver st fs wptr . + ( sym ~ WE.ExprBuilder scope st fs + , bak ~ CBO.OnlineBackend solver scope st fs + , CB.IsSymBackend sym bak + , LLVMMem.HasLLVMAnn sym + , W4O.OnlineSolver solver + , LLVMMem.HasPtrWidth wptr + , ?memOpts :: LLVMMem.MemOptions ) => + bak -> LLVMMem.MemImpl sym -> IO a) -> + IO a +withMem endianess action = withIONonceGenerator $ \nonce_gen -> do + sym <- WE.newExprBuilder WE.FloatIEEERepr WE.EmptyExprBuilderState nonce_gen + CBO.withZ3OnlineBackend sym CBO.NoUnsatFeatures noFeatures $ \bak -> do + let ?ptrWidth = knownNat @64 + let ?recordLLVMAnnotation = \_ _ _ -> pure () + let ?memOpts = LLVMMem.defaultMemOptions + mem <- LLVMMem.emptyMem endianess + action bak mem + +setCacheTerms :: CB.IsSymInterface sym => sym -> Bool ->IO () +setCacheTerms sym cache_terms_option = do + cache_terms_setting <- What4.getOptionSetting WE.cacheTerms $ What4.getConfiguration sym + void $ What4.setOpt cache_terms_setting cache_terms_option + +userSymbol' :: String -> What4.SolverSymbol +userSymbol' s = case What4.userSymbol s of + Left e -> error $ show e + Right symbol -> symbol + +assume :: (CB.IsSymBackend sym bak) => bak -> What4.Pred sym -> IO () +assume bak p = do + let sym = CB.backendGetSym bak + loc <- What4.getCurrentProgramLoc sym + CB.addAssumption bak (CB.GenericAssumption loc "assume" p) + +checkSat :: + W4O.OnlineSolver solver => + CBO.OnlineBackend solver scope st fs -> + WE.BoolExpr scope -> + IO (W4Sat.SatResult () ()) +checkSat bak p = + let err = fail "Online solving not enabled!" in + CBO.withSolverProcess bak err $ \proc -> + W4O.checkSatisfiable proc "" p + + +testArrayStride :: T.TestTree +testArrayStride = testCase "array stride" $ withMem LLVMD.BigEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024) + (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + + let byte_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @8 + let byte_storage_type = LLVMMem.bitvectorType 1 + let ptr_byte_repr = LLVMMem.LLVMPointerRepr $ knownNat @8 + + init_array_val <- LLVMMem.LLVMValArray byte_storage_type <$> + V.generateM (1024 * 1024) + (\i -> LLVMMem.packMemValue sym byte_storage_type byte_type_repr + =<< What4.bvLit sym (knownNat @8) (BV.mkBV knownNat (fromIntegral (mod i (512 * 1024))))) + mem2 <- LLVMMem.storeRaw + bak + mem1 + base_ptr + (LLVMMem.arrayType (1024 * 1024) byte_storage_type) + noAlignment + init_array_val + + stride <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (512 * 1024) + + i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth + ptr_i <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvMul sym stride i + ptr_i' <- ptrAdd sym ?ptrWidth ptr_i =<< What4.bvLit sym ?ptrWidth (BV.one ?ptrWidth) + + zero_bv <- What4.bvLit sym (knownNat @8) (BV.zero knownNat) + mem3 <- + doStore bak mem2 ptr_i byte_type_repr byte_storage_type noAlignment zero_bv + one_bv <- What4.bvLit sym (knownNat @8) (BV.one knownNat) + mem4 <- + doStore bak mem3 ptr_i' byte_type_repr byte_storage_type noAlignment one_bv + + at_0_val <- projectLLVM_bv bak + =<< doLoad bak mem4 base_ptr byte_storage_type ptr_byte_repr noAlignment + (Just (BV.zero knownNat)) @=? What4.asBV at_0_val + + j <- What4.freshConstant sym (userSymbol' "j") $ What4.BaseBVRepr ?ptrWidth + ptr_j <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvMul sym stride j + ptr_j' <- ptrAdd sym ?ptrWidth ptr_j =<< What4.bvLit sym ?ptrWidth (BV.one ?ptrWidth) + + at_j_val <- projectLLVM_bv bak + =<< doLoad bak mem4 ptr_j byte_storage_type ptr_byte_repr noAlignment + (Just (BV.zero knownNat)) @=? What4.asBV at_j_val + + at_j'_val <- projectLLVM_bv bak + =<< doLoad bak mem4 ptr_j' byte_storage_type ptr_byte_repr noAlignment + (Just (BV.one knownNat)) @=? What4.asBV at_j'_val + + +allocFreshArray :: + ( CB.IsSymBackend sym bak, LLVMMem.HasLLVMAnn sym, LLVMMem.HasPtrWidth wptr + , ?memOpts :: LLVMMem.MemOptions ) => + bak -> + LLVMMem.MemImpl sym -> + Integer -> + IO (LLVMMem.LLVMPtr sym wptr, What4.SymArray sym (SingleCtx (What4.BaseBVType wptr)) (What4.BaseBVType 8), LLVMMem.MemImpl sym) +allocFreshArray bak mem sz = do + let sym = CB.backendGetSym bak + sz_bv <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth sz + (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem sz_bv noAlignment + arr <- What4.freshConstant + sym + (userSymbol' "a") + (What4.BaseArrayRepr (Ctx.singleton $ What4.BaseBVRepr ?ptrWidth) (What4.BaseBVRepr (knownNat @8))) + mem2 <- LLVMMem.doArrayStore bak mem1 base_ptr noAlignment arr sz_bv + return (base_ptr, arr, mem2) + + +-- | This test case verifies that the symbolic aspects of the SMT-backed array +-- memory model works (e.g., that constraints on symbolic indexes work as +-- expected) +testMemArray :: T.TestTree +testMemArray = testCase "smt array memory model" $ withMem LLVMD.BigEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + -- Make a fresh allocation (backed by a fresh SMT array) of size 1024*1024 bytes. + -- The base pointer of the array is base_ptr + sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024) + (base_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + + arr <- What4.freshConstant + sym + (userSymbol' "a") + (What4.BaseArrayRepr + (Ctx.singleton $ What4.BaseBVRepr ?ptrWidth) + (What4.BaseBVRepr (knownNat @8))) + mem2 <- LLVMMem.doArrayStore bak mem1 base_ptr noAlignment arr sz + + let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64 + let long_storage_type = LLVMMem.bitvectorType 8 + let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64 + + -- Store a large known 8 byte value at a symbolic location in the array (at + -- @i@ bytes from the beginning of the array). The assumption constrains it + -- such that the location is within the first 1024 bytes of the array. + i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth + ptr_i <- ptrAdd sym ?ptrWidth base_ptr i + assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + some_val <- What4.bvLit sym (knownNat @64) (BV.mkBV knownNat 0x88888888f0f0f0f0) + mem3 <- + doStore bak mem2 ptr_i long_type_repr long_storage_type noAlignment some_val + + memset_ptr <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 2048) + memset_val <- What4.bvLit sym knownNat (BV.mkBV knownNat 0) + memset_sz <- What4.bvLit sym (knownNat @64) (BV.mkBV knownNat 10) + mem4 <- LLVMMem.doMemset bak (knownNat @64) mem3 memset_ptr memset_val memset_sz + + -- Read that same value back and make sure that they are the same + at_i_val <- projectLLVM_bv bak + =<< doLoad bak mem4 ptr_i long_storage_type ptr_long_repr noAlignment + res_i <- checkSat bak =<< What4.bvNe sym some_val at_i_val + True @=? W4Sat.isUnsat res_i + + -- Allocate another fresh arbitrary constant and add it to the base pointer. + -- Assume that i = j, then verify that reading from j yields the same value as + -- was written at i. + j <- What4.freshConstant sym (userSymbol' "j") $ What4.BaseBVRepr ?ptrWidth + ptr_j <- ptrAdd sym ?ptrWidth base_ptr j + assume bak =<< What4.bvEq sym i j + at_j_val <- projectLLVM_bv bak + =<< doLoad bak mem4 ptr_j long_storage_type ptr_long_repr noAlignment + res_j <- checkSat bak =<< What4.bvNe sym some_val at_j_val + True @=? W4Sat.isUnsat res_j + + +-- | Like testMemArray, but using some concrete indexes in a few places. This +-- test checks the implementation of saturated addition of two numbers. +-- +-- This is simulating the use of an SMT array to represent a program stack, and +-- ensures that: +-- +-- * Concrete indexing works as expected +-- * Goals that depend on the values of values stored in memory work +testMemArrayWithConstants :: T.TestTree +testMemArrayWithConstants = testCase "smt array memory model (with constant indexing)" $ do + withMem LLVMD.LittleEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + sz <- What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth (2 * 1024)) + (region_ptr, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + let mRepr = What4.BaseArrayRepr (Ctx.singleton (What4.BaseBVRepr ?ptrWidth)) (What4.BaseBVRepr (knownNat @8)) + backingArray <- What4.freshConstant sym (userSymbol' "backingArray") mRepr + mem2 <- LLVMMem.doArrayStore bak mem1 region_ptr noAlignment backingArray sz + + let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64 + let long_storage_type = LLVMMem.bitvectorType 8 + let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64 + + -- Make our actual base pointer the middle of the stack, to simulate having + -- some active frames above us + base_off <- What4.freshConstant sym (userSymbol' "baseOffset") (What4.BaseBVRepr ?ptrWidth) + assume bak =<< What4.bvUlt sym base_off =<< (What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 10)) + base_ptr <- ptrAdd sym ?ptrWidth region_ptr base_off -- =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + + -- Assume we have two arguments to our virtual function: + param_a <- What4.freshConstant sym (userSymbol' "paramA") (What4.BaseBVRepr (knownNat @64)) + param_b <- What4.freshConstant sym (userSymbol' "paramB") (What4.BaseBVRepr (knownNat @64)) + + -- The fake stack frame will start at @sp@ be: + -- + -- sp+8 : Stack slot for spilling a + slot_a <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 8) + -- sp+16 : Stack slot for spilling b + slot_b <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 16) + -- sp+24 : Stack slot for local variable c + slot_c <- ptrAdd sym ?ptrWidth base_ptr =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 24) + + -- Store a and b onto the stack + mem3 <- doStore bak mem2 slot_a long_type_repr long_storage_type noAlignment param_a + mem4 <- doStore bak mem3 slot_b long_type_repr long_storage_type noAlignment param_b + + -- Read a and b off of the stack and compute c = a+b (storing the result on the stack in c's slot) + valA0 <- projectLLVM_bv bak =<< doLoad bak mem4 slot_a long_storage_type ptr_long_repr noAlignment + valB0 <- projectLLVM_bv bak =<< doLoad bak mem4 slot_b long_storage_type ptr_long_repr noAlignment + mem5 <- doStore bak mem4 slot_c long_type_repr long_storage_type noAlignment =<< What4.bvAdd sym valA0 valB0 + + + valA1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_a long_storage_type ptr_long_repr noAlignment + valB1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_b long_storage_type ptr_long_repr noAlignment + valC1 <- projectLLVM_bv bak =<< doLoad bak mem5 slot_c long_storage_type ptr_long_repr noAlignment + + -- Add some assumptions to make our assertion actually hold (i.e., avoiding overflow) + let n64 = knownNat @64 + -- assume sym =<< What4.bvUlt sym param_a =<< What4.bvLit sym n64 (BV.mkBV n64 100) + -- assume sym =<< What4.bvUlt sym param_b =<< What4.bvLit sym n64 (BV.mkBV n64 100) + cLessThanA <- What4.bvSlt sym valC1 valA1 + cLessThanB <- What4.bvSlt sym valC1 valB1 + ifOverflow <- What4.orPred sym cLessThanA cLessThanB + + i64Max <- What4.bvLit sym n64 (BV.mkBV n64 0x7fffffffffffffff) + clamped_c <- What4.bvIte sym ifOverflow i64Max valC1 + mem6 <- doStore bak mem5 slot_c long_type_repr long_storage_type noAlignment clamped_c + + valC2 <- projectLLVM_bv bak =<< doLoad bak mem6 slot_c long_storage_type ptr_long_repr noAlignment + + aLessThanC <- What4.bvSle sym param_a valC2 + bLessThanC <- What4.bvSle sym param_b valC2 + assertion <- What4.andPred sym aLessThanC bLessThanC + goal <- What4.notPred sym assertion + res <- checkSat bak goal + True @=? W4Sat.isUnsat res + + +-- | This test case checks the memcpy aspect of the SMT-backed array memory model +testMemArrayCopy :: T.TestTree +testMemArrayCopy = testCase "smt array copy memory model" $ withMem LLVMD.LittleEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + + setCacheTerms sym True + + (dst_base_ptr, dst_arr, mem1) <- allocFreshArray bak mem0 (1024 * 1024) + (src_base_ptr, src_arr, mem2) <- allocFreshArray bak mem1 1024 + + i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth + dst_ptr <- ptrAdd sym ?ptrWidth dst_base_ptr i + assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + len <- What4.freshConstant sym (userSymbol' "l") $ What4.BaseBVRepr ?ptrWidth + assume bak =<< What4.bvUlt sym len =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + mem3 <- LLVMMem.doMemcpy bak ?ptrWidth mem2 False dst_ptr src_base_ptr len + + zero_bv <- What4.bvLit sym ?ptrWidth $ BV.zero ?ptrWidth + expected_arr <- What4.arrayCopy sym dst_arr i src_arr zero_bv len + expected_val <- What4.arrayLookup sym expected_arr $ Ctx.singleton i + + actual_val <- projectLLVM_bv bak + =<< doLoad bak mem3 dst_ptr (LLVMMem.bitvectorType 1) (LLVMMem.LLVMPointerRepr $ knownNat @8) noAlignment + + foo <- What4.bvEq sym expected_val actual_val + (Just True) @=? What4.asConstantPred foo + + +-- | This test case checks the memset aspect of the SMT-backed array memory model +testMemArraySet :: T.TestTree +testMemArraySet = testCase "smt array copy memory model" $ withMem LLVMD.LittleEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + setCacheTerms sym True + + (base_ptr, arr, mem1) <- allocFreshArray bak mem0 (1024 * 1024) + + i <- What4.freshConstant sym (userSymbol' "i") $ What4.BaseBVRepr ?ptrWidth + ptr_i <- ptrAdd sym ?ptrWidth base_ptr i + assume bak =<< What4.bvUlt sym i =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + val <- What4.freshConstant sym (userSymbol' "v") $ What4.BaseBVRepr $ knownNat @8 + len <- What4.freshConstant sym (userSymbol' "l") $ What4.BaseBVRepr ?ptrWidth + assume bak =<< What4.bvUlt sym len =<< What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 1024) + mem3 <- LLVMMem.doMemset bak ?ptrWidth mem1 ptr_i val len + + expected_arr <- What4.arraySet sym arr i val len + expected_val <- What4.arrayLookup sym expected_arr $ Ctx.singleton i + + actual_val <- projectLLVM_bv bak + =<< doLoad bak mem3 ptr_i (LLVMMem.bitvectorType 1) (LLVMMem.LLVMPointerRepr $ knownNat @8) noAlignment + + foo <- What4.bvEq sym expected_val actual_val + (Just True) @=? What4.asConstantPred foo + + +testMemWritesIndexed :: T.TestTree +testMemWritesIndexed = testCase "indexed memory writes" $ withMem LLVMD.BigEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + let count = 100 * 1000 + + sz <- What4.bvLit sym ?ptrWidth (BV.mkBV ?ptrWidth 8) + (base_ptr1, mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + (base_ptr2, mem2) <- LLVMMem.mallocRaw bak mem1 sz noAlignment + + let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64 + let long_storage_type = LLVMMem.bitvectorType 8 + let ptr_long_repr = LLVMMem.LLVMPointerRepr $ knownNat @64 + + zero_val <- What4.bvLit sym (knownNat @64) (BV.zero knownNat) + mem3 <- doStore + bak + mem2 + base_ptr1 + long_type_repr + long_storage_type + noAlignment + zero_val + + mem4 <- foldlM + (\mem' i -> + doStore bak mem' base_ptr2 long_type_repr long_storage_type noAlignment + =<< What4.bvLit sym (knownNat @64) i) + mem3 + (BV.enumFromToUnsigned (BV.zero (knownNat @64)) (BV.mkBV knownNat count)) + + forM_ [0 .. count] $ \_ -> do + val1 <- projectLLVM_bv bak + =<< doLoad bak mem4 base_ptr1 long_storage_type ptr_long_repr noAlignment + (Just (BV.zero knownNat)) @=? What4.asBV val1 + + val2 <- projectLLVM_bv bak + =<< doLoad bak mem4 base_ptr2 long_storage_type ptr_long_repr noAlignment + (Just (BV.mkBV knownNat count)) @=? What4.asBV val2 + +testMemAllocs :: T.TestTree +testMemAllocs = + testCase "memory model alloc/free" $ + withMem LLVMD.BigEndian $ \bak mem0 -> + do let sym = CB.backendGetSym bak + sz1 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 128 + sz2 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 72 + sz3 <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 32 + (ptr1, mem1) <- LLVMMem.mallocRaw bak mem0 sz1 noAlignment + (ptr2, mem2) <- LLVMMem.mallocRaw bak mem1 sz2 noAlignment + mem3 <- LLVMMem.doFree bak mem2 ptr2 + (ptr3, mem4) <- LLVMMem.mallocRaw bak mem3 sz3 noAlignment + mem5 <- LLVMMem.doFree bak mem4 ptr1 + mem6 <- LLVMMem.doFree bak mem5 ptr3 + + let isAllocated = LLVMMem.isAllocatedAlignedPointer sym ?ptrWidth noAlignment LLVMMem.Mutable + assertions <- + sequence + [ isAllocated ptr1 (Just sz1) mem1 + , isAllocated ptr1 (Just sz1) mem2 + , isAllocated ptr1 (Just sz1) mem3 + , isAllocated ptr1 (Just sz1) mem4 + , isAllocated ptr1 (Just sz1) mem5 >>= What4.notPred sym + , isAllocated ptr1 (Just sz1) mem6 >>= What4.notPred sym + + , isAllocated ptr2 (Just sz2) mem1 >>= What4.notPred sym + , isAllocated ptr2 (Just sz2) mem2 + , isAllocated ptr2 (Just sz2) mem3 >>= What4.notPred sym + , isAllocated ptr2 (Just sz2) mem4 >>= What4.notPred sym + , isAllocated ptr2 (Just sz2) mem5 >>= What4.notPred sym + , isAllocated ptr2 (Just sz2) mem6 >>= What4.notPred sym + + , isAllocated ptr3 (Just sz3) mem1 >>= What4.notPred sym + , isAllocated ptr3 (Just sz3) mem2 >>= What4.notPred sym + , isAllocated ptr3 (Just sz3) mem3 >>= What4.notPred sym + , isAllocated ptr3 (Just sz3) mem4 + , isAllocated ptr3 (Just sz3) mem5 + , isAllocated ptr3 (Just sz3) mem6 >>= What4.notPred sym + ] + assertion <- foldM (What4.andPred sym) (What4.truePred sym) assertions + res <- checkSat bak =<< What4.notPred sym assertion + True @=? W4Sat.isUnsat res + +-- | This test case checks that 'doInvalidate' behaves as expected with and +-- without 'laxLoadsAndStores' enabled. +testMemInvalidate :: T.TestTree +testMemInvalidate = + testCase "memory invalidation" $ withMem LLVMD.BigEndian $ \bak mem0 -> + do let sym = CB.backendGetSym bak + sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 64 + let long_type_repr = Crucible.baseToType $ What4.BaseBVRepr $ knownNat @64 + long_storage_type = LLVMMem.bitvectorType 8 + zero_val <- What4.bvLit sym (knownNat @64) (BV.zero knownNat) + + let withInvalidatedReadVal memOpts k = do + let ?memOpts = memOpts + -- First, allocate some memory on the stack... + (ptr, mem1) <- LLVMMem.doAlloca bak mem0 sz noAlignment "" + -- ...write some value to it (the exact value is unimportant)... + mem2 <- LLVMMem.doStore bak mem1 ptr + long_type_repr long_storage_type + noAlignment zero_val + -- ...invalidate the memory... + mem3 <- LLVMMem.doInvalidate bak ?ptrWidth mem2 ptr "" sz + -- ...and finally, read from the invalidated memory. + partVal <- LLVMMemG.readMem sym ?ptrWidth Nothing ptr + long_storage_type noAlignment + (LLVMMem.memImplHeap mem3) + k partVal + + testLaxInvalidatedRead :: String -> LLVMMem.IndeterminateLoadBehavior -> IO () + testLaxInvalidatedRead stability indeterminateLoadBehavior = + withInvalidatedReadVal (?memOpts{ LLVMMem.laxLoadsAndStores = True + , LLVMMem.indeterminateLoadBehavior = indeterminateLoadBehavior + }) $ \partVal -> + case partVal of + LLVMMem.NoErr p _val -> do + res <- checkSat bak p + True @=? W4Sat.isSat res + LLVMMem.Err p -> assertFailure $ unlines + [ "Reading from invalidated, " ++ stability ++ "-symbolic memory unexpectedly failed" + , "Predicate: " ++ show p + ] + + -- Test with laxLoadsAndStores disabled, where reading from invalidated + -- memory should result in an error. + withInvalidatedReadVal (?memOpts{LLVMMem.laxLoadsAndStores = False}) $ \partVal -> + case partVal of + LLVMMem.Err p -> do + res <- checkSat bak p + True @=? W4Sat.isUnsat res + LLVMMem.NoErr p val -> assertFailure $ unlines + [ "Reading from invalidated memory unexpectedly succeeded" + , "Predicate: " ++ show p + , "LLVM value read: " ++ show val + ] + + -- Test with laxLoadsAndStores enabled, using both the + -- StableSymbolic and UnstableSymbolic settings for + -- indeterminateLoadBehavior. Here, reading from invalidated memory should succeed. + testLaxInvalidatedRead "stable" LLVMMem.StableSymbolic + testLaxInvalidatedRead "unstable" LLVMMem.UnstableSymbolic + +-- | Test storing and retrieving pointer in an SMT-backed array memory model +testPointerStore :: T.TestTree +testPointerStore = testCase "pointer store" $ withMem LLVMD.BigEndian $ \bak mem0 -> do + let sym = CB.backendGetSym bak + -- Allocate two blocks + sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth (1024 * 1024) + (base_ptr1, _) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + (base_ptr2, block2_mem1) <- LLVMMem.mallocRaw bak mem0 sz noAlignment + + -- Store the first base pointer in the second block + let pointer_storage_type = LLVMMem.bitvectorType 8 + let base_ptr1_val = LLVMMem.ptrToPtrVal base_ptr1 + block2_mem2 <- LLVMMem.storeRaw bak + block2_mem1 + base_ptr2 + pointer_storage_type + noAlignment + base_ptr1_val + -- Read the pointer back + base_ptr1_back <- LLVMMem.loadRaw sym + block2_mem2 + base_ptr2 + pointer_storage_type + noAlignment + + -- Assert that the read pointer is equal to the original pointer + base_ptr1_back_safe <- LLVMMem.assertSafe bak base_ptr1_back + is_equal <- LLVMMem.testEqual sym base_ptr1_val base_ptr1_back_safe + case is_equal of + Nothing -> assertFailure "testEqual failed" + Just p -> do + goal <- What4.notPred sym p + res <- checkSat bak goal + True @=? W4Sat.isUnsat res + +-- | Test storing and retrieving a struct with and without 'laxLoadsAndStores' +-- enabled. +testStructStore :: T.TestTree +testStructStore = testCase "struct store" $ withMem LLVMD.BigEndian $ \bak mem0 -> + do let sym = CB.backendGetSym bak + sz <- What4.bvLit sym ?ptrWidth $ BV.mkBV ?ptrWidth 64 + let struct_storage_type = LLVMMem.mkStructType $ V.fromList + [ (LLVMMem.bitvectorType 2, 2) + , (LLVMMem.bitvectorType 4, 0) + ] + let w16 = knownNat @16 + let w32 = knownNat @32 + let struct_type_repr = Crucible.StructRepr $ + Ctx.Empty Ctx.:> + LLVMMem.LLVMPointerRepr w16 Ctx.:> + LLVMMem.LLVMPointerRepr w32 + let struct_bv1 = BV.mkBV w16 27 + let struct_bv2 = BV.mkBV w32 42 + struct_sym_bv1 <- What4.bvLit sym w16 struct_bv1 + struct_sym_bv2 <- What4.bvLit sym w32 struct_bv2 + struct_field1 <- LLVMMem.llvmPointer_bv sym struct_sym_bv1 + struct_field2 <- LLVMMem.llvmPointer_bv sym struct_sym_bv2 + let struct_val = Ctx.Empty Ctx.:> + CS.RV struct_field1 Ctx.:> + CS.RV struct_field2 + + let testWithOpts memOpts = do + let ?memOpts = memOpts + -- First, allocate some memory on the stack... + (ptr, mem1) <- LLVMMem.doAlloca bak mem0 sz noAlignment "" + -- ...write a struct to it... + mem2 <- LLVMMem.doStore bak mem1 ptr + struct_type_repr struct_storage_type + noAlignment struct_val + -- ...read back the struct... + struct_val' <- LLVMMem.doLoad bak mem2 ptr + struct_storage_type struct_type_repr noAlignment + -- ...and finally, check that the struct read from memory is the + -- same as the original struct. + let checkField :: + forall w sym bak. + CB.IsSymBackend sym bak => + bak -> + BV.BV w -> + CS.RegValue' sym (LLVMMem.LLVMPointerType w) -> + IO () + checkField bak' expectedBV actualPtrRV = do + actualSymBV <- projectLLVM_bv bak' $ CS.unRV actualPtrRV + Just expectedBV @=? What4.asBV actualSymBV + checkField bak struct_bv1 (struct_val'^._1) + checkField bak struct_bv2 (struct_val'^._2) + + testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = False }) + testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = True + , LLVMMem.indeterminateLoadBehavior = LLVMMem.StableSymbolic + }) + testWithOpts (?memOpts{ LLVMMem.laxLoadsAndStores = True + , LLVMMem.indeterminateLoadBehavior = LLVMMem.UnstableSymbolic + }) diff --git a/test/TestTranslation.hs b/test/TestTranslation.hs new file mode 100644 --- /dev/null +++ b/test/TestTranslation.hs @@ -0,0 +1,62 @@ +module TestTranslation + ( + translationTests + ) +where + +import qualified Data.Foldable as F +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set + +import qualified Test.Tasty as T +import Test.Tasty.HUnit ( testCase, (@=?) ) +import Test.Tasty.QuickCheck ( testProperty ) + +import Lang.Crucible.LLVM.Translation.Aliases ( reverseAliases ) + + +translationTests :: T.TestTree +translationTests = + T.testGroup "Translation" + [ + T.testGroup "Aliases" $ + + ------------- Tests for reverseAliases + + let evenAlias xs x = + let s = Set.fromList (F.toList xs) + in if even x && Set.member x s + then Just (x `div` 2) + else Nothing + addTargets xs = xs <> fmap (`div` 2) (Seq.filter even xs) + in + [ testCase "reverseAliases: empty" $ + Map.empty @=? + reverseAliases id (const Nothing) (Seq.empty :: Seq.Seq Int) + + , testProperty "reverseAliases: singleton" $ \x -> + Map.singleton (x :: Int) Set.empty == + reverseAliases id (const Nothing) (Seq.singleton x) + + , -- The result should not depend on ordering + testProperty "reverseAliases: reverse" $ \xs -> + let -- no self-aliasing allowed + xs' = addTargets (Seq.filter (/= 0) xs) + in reverseAliases id (evenAlias xs) (xs' :: Seq.Seq Int) == + reverseAliases id (evenAlias xs) (Seq.reverse xs') + + , -- Every item should appear exactly once + testProperty "reverseAliases: xor" $ \xs -> + let xs' = addTargets (Seq.filter (/= 0) xs) + result = reverseAliases id (evenAlias xs) (xs' :: Seq.Seq Int) + keys = Map.keysSet result + values = Set.unions (Map.elems result) + -- + xor True a = not a + xor False a = a + -- + in all (\x -> Set.member x keys `xor` Set.member x values) xs' + ] + + ] diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +-- Crucible +import Lang.Crucible.FunctionHandle ( newHandleAllocator ) + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Some +import Data.Parameterized.NatRepr +import Data.Parameterized.SymbolRepr ( SomeSym(SomeSym) ) + +-- LLVM +import qualified Text.LLVM.AST as L +import Text.LLVM.AST (Module) +import Data.LLVM.BitCode + +-- Tasty +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.Options as TO +import qualified Test.Tasty.Runners as TR +import qualified Test.Tasty.Sugar as TS + +-- General +import Control.Lens (view) +import Control.Monad +import Data.Either ( fromRight ) +import Data.Maybe ( catMaybes ) +import GHC.TypeLits +import qualified Data.Map.Strict as Map +import Data.Proxy ( Proxy(..) ) +import qualified System.Directory as Dir +import System.Environment ( lookupEnv ) +import System.Exit ( ExitCode(..) ) +import System.FilePath ( (-<.>), splitExtension, splitFileName ) +import qualified System.Process as Proc + +-- Modules being tested +import Lang.Crucible.LLVM.MemModel ( mkMemVar ) +import Lang.Crucible.LLVM.MemType +import Lang.Crucible.LLVM.Translation + +import TestFunctions +import TestGlobals +import TestMemory +import TestTranslation + + +data LLVMAssembler (source :: Symbol) = LLVMAssembler String + deriving (Eq, Show) + +instance TO.IsOption (SomeSym LLVMAssembler) where + defaultValue = SomeSym $ LLVMAssembler @"default" "llvm-as" + parseValue = Just . SomeSym . LLVMAssembler @"option" + optionName = pure "llvm-assembler" + optionHelp = pure $ unwords ["The LLVM assembler to use on .ll files" + ,"(overrides the LLVM_AS environment variable," + ,"default is \"llvm-as\")"] + +data Clang (source :: Symbol) = Clang String + deriving (Eq, Show) + +instance TO.IsOption (SomeSym Clang) where + defaultValue = SomeSym $ Clang @"default" "clang" + parseValue = Just . SomeSym . Clang @"option" + optionName = pure "clang" + optionHelp = pure $ unwords ["The clang binary to use to compile C files" + ,"(overrides the CLANG environment variable," + ,"default is \"clang\")"] + +optionSource :: opt (source :: Symbol) -> Proxy source +optionSource _ = Proxy + +doProc :: String -> [String] -> IO ProcResult +doProc !exe !args = do + (exitCode, stdout, stderr) <- Proc.readProcessWithExitCode exe args "" + pure $ (exitCodeToInt exitCode, stdout, stderr) + where exitCodeToInt ExitSuccess = 0 + exitCodeToInt (ExitFailure i) = i + +type ProcResult = (Int, String, String) + +assertProcSuccess :: String -> String -> ProcResult -> Assertion +assertProcSuccess msg file (exitCode, stdout, stderr) = do + when (exitCode /= 0) $ do + putStrLn $ msg ++ " " ++ file ++ " failure" + putStrLn stdout + putStrLn stderr + exitCode == 0 @? msg ++ " " ++ file ++ " attempt failed with " ++ show exitCode + + +-- | Compile a C file with clang, returning the exit code +compile :: Clang "executable" -> FilePath -> IO ProcResult +compile (Clang clang) !file = doProc clang ["-emit-llvm", "-g", "-O0", "-c", file] + +-- | Assemble a ll file with llvm-as, returning the exit code +assemble :: LLVMAssembler "executable" -> FilePath -> FilePath -> IO ProcResult +assemble (LLVMAssembler llvm_as) !inputFile !outputFile = + doProc llvm_as ["-o", outputFile, inputFile] + +-- | Parse an LLVM bit-code file. +-- Mostly copied from crucible-c. +parseLLVM :: FilePath -> IO (Either String Module) +parseLLVM !file = + parseBitCodeFromFile file >>= + \case + Left err -> pure $ Left $ "Couldn't parse LLVM bitcode from file" + ++ file ++ "\n" ++ show err + Right m -> pure $ Right m + +llvmTestIngredients :: [TR.Ingredient] +llvmTestIngredients = includingOptions [ TO.Option (Proxy @(SomeSym LLVMAssembler)) + , TO.Option (Proxy @(SomeSym Clang)) + ] : + includingOptions TS.sugarOptions : + TS.sugarIngredients [cCube, lCube] <> + defaultIngredients + +cCube, lCube :: TS.CUBE +cCube = TS.mkCUBE { TS.inputDirs = ["test/c"] + , TS.rootName = "*.c" + , TS.separators = "." + , TS.expectedSuffix = "checks" + } + +lCube = cCube { TS.inputDirs = ["test/ll"] + , TS.rootName = "*.ll" + } + + +main :: IO () +main = do + do testSweets <- concat <$> (mapM TS.findSugar [cCube, lCube]) + + fileTests <- TS.withSugarGroups testSweets testGroup $ + \sweets _ expectation -> do + -- The expected file contains a list of the tests to run + -- on the LLVM translation. + checklist <- lines <$> readFile (TS.expectedFile expectation) + return $ + testBuildTranslation (TS.rootFile sweets) $ + (\getTrans -> testGroup "checks" $ map (transCheck getTrans) checklist) + + defaultMainWithIngredients llvmTestIngredients $ + testGroup "Tests" + [ functionTests + , globalTests + , memoryTests + , translationTests + , testGroup "Input Files" $ fileTests + ] + + + +testBuildTranslation :: FilePath -> (IO (Some ModuleTranslation) -> TestTree) -> [TestTree] +testBuildTranslation srcPath llvmTransTests = + -- n.b. srcPath may be a relative path + let (dName, srcName) = splitFileName srcPath + (fName, ext) = splitExtension srcName + bcPath = srcPath -<.> ".bc" + (_, bcName) = splitFileName bcPath + + genBCName = case ext of + ".c" -> "compile " <> fName + ".ll" -> "assemble " <> fName + _ -> error $ "Cannot build LLVM bitcode file from a " ++ ext ++ " file" + parseBCName = "parse " ++ fName ++ " bitcode" + translateName = "translate " ++ fName + + c_compile = + if (ext == ".c") + then + Just $ askOption $ \(SomeSym clangOption :: SomeSym Clang) -> + testCase genBCName $ do + clang <- + let src = optionSource clangOption in + case sameSymbol src (Proxy :: Proxy "option") of + Just Refl -> let Clang c = clangOption in return $ Clang c + _ -> case sameSymbol src (Proxy :: Proxy "default") of + Just Refl -> maybe (Clang "clang") Clang <$> lookupEnv "CLANG" + _ -> error $ "Unknown Clang specification type: " <> symbolVal src + assertProcSuccess "compile" srcPath =<< + Dir.withCurrentDirectory dName (compile clang srcName) + else Nothing + + llvm_assemble = + if (ext == ".ll") + then Just $ askOption $ \(SomeSym assemblerOption :: SomeSym LLVMAssembler) -> + testCase genBCName $ do + llvm_as <- + let src = optionSource assemblerOption in + case sameSymbol src (Proxy :: Proxy "option") of + Just Refl -> let LLVMAssembler a = assemblerOption + in return $ LLVMAssembler a + _ -> case sameSymbol src (Proxy :: Proxy "default") of + Just Refl -> maybe (LLVMAssembler "llvm-as") LLVMAssembler <$> + lookupEnv "LLVM_AS" + _ -> error $ "Unknown LLVM Assembler specification type: " <> symbolVal src + + assertProcSuccess "assemble" srcPath =<< + Dir.withCurrentDirectory dName (assemble llvm_as srcName bcName) + else Nothing + + parse_bitcode = + testCase parseBCName $ + parseLLVM bcPath >>= \case + Left err -> do + putStrLn $ "Failed to parse " ++ bcPath + putStrLn err + err @?= "" + Right _ -> pure () + + trans = do halloc <- newHandleAllocator + let ?transOpts = defaultTranslationOptions + memVar <- mkMemVar "buildTranslation_test_llvm_memory" halloc + m <- (translateModule halloc memVar =<< + (fromRight (error "parsing was already verified") <$> parseLLVM bcPath)) + return m + + translate_bitcode = + testCase translateName $ do + trans >>= \(Some modTrans) -> + not (null $ view modTransDefs modTrans) @? "Translation of " ++ bcPath ++ " was empty (failed?)" + + + in catMaybes + [ c_compile + , llvm_assemble + , Just $ after AllSucceed genBCName parse_bitcode + , Just $ after AllSucceed parseBCName translate_bitcode + , Just $ after AllSucceed translateName (llvmTransTests trans) + ] + + +transCheck :: IO (Some ModuleTranslation) -> String -> TestTree +transCheck getTrans = \case + + "extern_int" -> + testCase "valid global extern variable reference" $ do + Some t <- getTrans + Map.singleton (L.Symbol "extern_int") (Right (i32, Nothing)) @=? + Map.map snd (view globalInitMap t) + + "x=42" -> + testCase "valid global integer symbol reference" $ do + Some t <- getTrans + Map.singleton (L.Symbol "x") (Right $ (i32, Just $ IntConst (knownNat @32) (BV.mkBV knownNat 42))) @=? + Map.map snd (view globalInitMap t) + + "z.xx=17" -> + testCase "valid global struct field symbol reference" $ do + Some t <- getTrans + IntConst (knownNat @32) (BV.mkBV knownNat 17) @=? + case snd <$> Map.lookup (L.Symbol "z") (view globalInitMap t) of + Just (Right (_, Just (StructConst _ (x : _)))) -> x + _ -> IntConst (knownNat @1) (BV.zero knownNat) + + "x uninitialized" -> + testCase "valid global unitialized variable reference" $ do + Some t <- getTrans + Map.singleton (L.Symbol "x") (Right $ (i32, Just $ ZeroConst i32)) @=? + Map.map snd (view globalInitMap t) + + -- We're really just checking that the translation succeeds without + -- exceptions. + "" -> testCase "no additional checks" $ return () + + other -> testCase other $ assertFailure $ "Unknown check: " <> other