diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,29 @@ +# 0.7 -- 2024-08-30 + +* Add support for GHC 9.8 +* Add integer-related `llvm.vector.reduce.*` intrinsics. +* Add workaround to allow loading bitcode using LLVM's reltable lookup optimization. +* `register_llvm_overrides{,_}` now returns the list of overrides that were + applied. +* The `doMallocHandle` function was removed. +* The `RegOverrideM` monad was replaced by the `MakeOverride` function newtype. +* Several type parameters were removed from `OverrideTemplate`, and the `ext` + parameter was added. This had downstream effects in `basic_llvm_override`, + `polymorphic1_llvm_override`, and other functions for registering overrides. +* Override registration code was generalized. `bind_llvm_{handle,func}` + now don't require a whole `LLVMContext`, just a `GlobalVar Mem`, and are + polymorphic over `ext`. +* `build_llvm_override` is now generic over the `ext` type parameter. This + should be a backwards-compatible change. +* `LLVMOverride` now has an additional `ext` type parameter. See the Haddocks + for `LLVMOverride` for details and motivation. +* The `llvmOverride_def` field of `LLVMOverride` no longer takes a `bak` + argument. To retrieve the current symbolic backend, use + `Lang.Crucible.Simulator.OverrideSim.ovrWithBackend`. +* Add overrides for integer-related `llvm.vector.reduce.*` intrinsics. +* Add support for atomic `fadd`, `fsub`, `fmax`, `fmin`, `uinc_wrap`, and + `udec_wrap` operations in `atomicrmw` instructions. + # 0.6 -- 2024-02-05 * `bindLLVMFunPtr` now accepts an `Text.LLVM.AST.Symbol` rather than a whole `Declare`. diff --git a/crucible-llvm.cabal b/crucible-llvm.cabal --- a/crucible-llvm.cabal +++ b/crucible-llvm.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: crucible-llvm -Version: 0.6 +Version: 0.7 Author: Galois Inc. Copyright: (c) Galois, Inc 2014-2022 Maintainer: rscott@galois.com, kquick@galois.com, langston@galois.com @@ -33,7 +33,7 @@ library import: bldflags build-depends: - base >= 4.13 && < 4.19, + base >= 4.13 && < 4.20, attoparsec, bv-sized >= 1.0.0, bytestring, @@ -71,8 +71,10 @@ Lang.Crucible.LLVM.Errors.UndefinedBehavior Lang.Crucible.LLVM.Eval Lang.Crucible.LLVM.Extension + Lang.Crucible.LLVM.Functions Lang.Crucible.LLVM.Globals Lang.Crucible.LLVM.Intrinsics + Lang.Crucible.LLVM.Intrinsics.Cast Lang.Crucible.LLVM.Intrinsics.Libc Lang.Crucible.LLVM.Intrinsics.LLVM Lang.Crucible.LLVM.MalformedLLVMModule @@ -89,6 +91,7 @@ Lang.Crucible.LLVM.QQ Lang.Crucible.LLVM.SymIO Lang.Crucible.LLVM.SimpleLoopFixpoint + Lang.Crucible.LLVM.SimpleLoopFixpointCHC Lang.Crucible.LLVM.SimpleLoopInvariant Lang.Crucible.LLVM.Translation Lang.Crucible.LLVM.Translation.Aliases @@ -100,6 +103,7 @@ Lang.Crucible.LLVM.Extension.Syntax Lang.Crucible.LLVM.Intrinsics.Common Lang.Crucible.LLVM.Intrinsics.Libcxx + Lang.Crucible.LLVM.Intrinsics.Match Lang.Crucible.LLVM.Intrinsics.Options Lang.Crucible.LLVM.MemModel.Common Lang.Crucible.LLVM.MemModel.Options diff --git a/src/Lang/Crucible/LLVM.hs b/src/Lang/Crucible/LLVM.hs --- a/src/Lang/Crucible/LLVM.hs +++ b/src/Lang/Crucible/LLVM.hs @@ -40,6 +40,7 @@ import Lang.Crucible.LLVM.Eval (llvmExtensionEval) import Lang.Crucible.Panic (panic) import Lang.Crucible.LLVM.Extension (ArchWidth) +import Lang.Crucible.LLVM.Functions (bindLLVMHandle, bindLLVMCFG) import Lang.Crucible.LLVM.Intrinsics import Lang.Crucible.LLVM.MemModel ( llvmStatementExec, HasPtrWidth, HasLLVMAnn, MemOptions, MemImpl @@ -84,12 +85,12 @@ , 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 + let mvar = llvmMemVar llvmCtx + bindLLVMCFG mvar (L.decName decl) cfg + binds <- use (stateContext . functionBindings) + let h = cfgHandle cfg when (isJust $ lookupHandleMap h $ fnBindings binds) $ do loc <- liftIO . getCurrentProgramLoc =<< getSymInterface liftIO (handleWarning (LLVMTranslationWarning sym (plSourceLoc loc) "LLVM function handle registered twice")) @@ -127,7 +128,9 @@ , show sym ] Just (decl, SomeHandle h) -> - do -- Bind the function handle we just created to the following bootstrapping code, + do let llvmCtx = mtrans ^. transContext + let mvar = llvmMemVar llvmCtx + -- 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 = @@ -150,14 +153,13 @@ Just Refl -> do liftIO $ mapM_ handleWarning warns -- Here we rebind the function handle to use the translated CFG - bindFnHandle h (UseCFG cfg (postdomInfo cfg)) + bindLLVMHandle mvar (L.decName decl) 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 + bindLLVMHandle mvar (L.decName decl) h s llvmGlobalsToCtx diff --git a/src/Lang/Crucible/LLVM/Functions.hs b/src/Lang/Crucible/LLVM/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Functions.hs @@ -0,0 +1,277 @@ +-- | +-- Module : Lang.Crucible.LLVM.Functions +-- Description : Register functions (CFGs and overrides) +-- Copyright : (c) Galois, Inc 2024 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-- Registering functions to be used with the LLVM memory model is somewhat more +-- complex than for other Crucible frontends, as LLVM has a notion of function +-- pointers. Each function to be registered has to go through a few steps (the +-- first two are common to all Crucible frontends): +-- +-- * Create a 'FnHandle' and a 'FnState' (a translated CFG or an override) +-- * Bind the 'FnHandle' to the 'FnState' ('OverrideSim.bindFnHandle') +-- * Create a (global, immutable, zero-sized) allocation corresponding to the +-- function in the 'MemImpl' ('allocFunPtr') +-- * Register the correspondence between the function\'s name (and any aliases) +-- and its global allocation ('registerGlobal', or via 'registerFunPtr') +-- * Register the correspondence between the function\'s allocation and its +-- handle ('doInstallHandle', or via 'bindLLVMHandle', 'bindLLVMCFG', or +-- 'bindLLVMFunc') +-- +-- This module provides helpers to accomplish all of this. They\'re ordered +-- roughly low-level/customizable to high-level/automated. +-- +-- Perhaps surprisingly, there\'s no function that does all of the above at +-- once. This is because there are two main places where binding functions +-- happens: +-- +-- * "Lang.Crucible.LLVM" registers translated CFGs, but does so lazily. In +-- particular, this means that it initially binds the handle and allocation to +-- a \"stub\" that, when called, will translate the actual CFG and then +-- re-bind the handle and allocation to it. +-- * "Lang.Crucible.LLVM.Intrinsics.Common" registers overrides, which generally +-- apply to functions that are @declare@d but not @define@d. Thus, they +-- already have corresponding allocations, which just need to be associated +-- with the override. +-- +-- Prior to these, function allocation happens in +-- 'Lang.Crucible.LLVM.Globals.initializeMemory'. +------------------------------------------------------------------------ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} + +module Lang.Crucible.LLVM.Functions + ( allocFunPtr + , allocLLVMFunPtr + , allocLLVMFunPtrs + , registerFunPtr + , bindLLVMFunPtr + , bindLLVMHandle + , bindLLVMCFG + , bindLLVMFunc + ) where + +import Control.Lens (use) +import Control.Monad (foldM) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text + +import qualified Text.LLVM.AST as L + +import qualified Data.Parameterized.Context as Ctx + +import What4.FunctionName (functionNameFromText) +import qualified What4.Interface as W4 + +import Lang.Crucible.Analysis.Postdom (postdomInfo) +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.CFG.Core (CFG) +import Lang.Crucible.CFG.Core (TypeRepr(..), cfgHandle) +import Lang.Crucible.FunctionHandle (FnHandle(handleArgTypes), mkHandle') +import Lang.Crucible.Simulator.ExecutionTree (stateContext) +import Lang.Crucible.Simulator (FnState(..), SimContext(..)) +import Lang.Crucible.Simulator.OverrideSim (OverrideSim) +import qualified Lang.Crucible.Simulator.OverrideSim as OverrideSim + +import Lang.Crucible.LLVM.DataLayout +import Lang.Crucible.LLVM.MemModel +import qualified Lang.Crucible.LLVM.MemModel as G +import Lang.Crucible.LLVM.Translation.Monad +import Lang.Crucible.LLVM.Extension (LLVM) + +-- | Create a global allocation to be assocated with a function. +-- +-- The returned allocation is global ('G.GlobalAlloc'), immutable +-- ('G.Immutable'), and has a size and alignment of zero. +allocFunPtr :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + MemImpl sym -> + -- | Function Name + String -> + IO (LLVMPtr sym wptr, MemImpl sym) +allocFunPtr bak mem nm = do + let sym = backendGetSym bak + z <- W4.bvZero sym ?ptrWidth + doMalloc bak G.GlobalAlloc G.Immutable nm mem z noAlignment + +-- | Create a global allocation assocated with a function (see 'allocFunPtr'), +-- and register the function\'s primary symbol and its aliases as associated +-- with that allocation. +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 + (ptr, mem') <- allocFunPtr bak mem displayName + return $ (ptr, registerGlobal mem' (nm:aliases) ptr) + +-- Not exported +funAliases :: + LLVMContext arch -> + L.Symbol -> + [L.Symbol] +funAliases llvmCtx symbol = + let aliases = llvmFunctionAliases llvmCtx + in map L.aliasName $ maybe [] Set.toList $ Map.lookup symbol aliases + +-- | Create a global allocation assocated with a function (see 'allocFunPtr'), +-- register the function\'s primary symbol and its aliases as associated with +-- that allocation (see 'registerFunPtr'), looking up the aliases from the +-- 'LLVMContext'. +allocLLVMFunPtr :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + LLVMContext arch -> + MemImpl sym -> + Either L.Declare L.Define -> + IO (LLVMPtr sym wptr, 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 aliases = funAliases llvm_ctx symbol + registerFunPtr bak mem displayString symbol aliases + +-- | Create global allocations associated with each function in a module (see +-- 'allocLLVMFunPtr'). +allocLLVMFunPtrs :: + ( IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) => + bak -> + LLVMContext arch -> + MemImpl sym -> + L.Module -> + IO (MemImpl sym) +allocLLVMFunPtrs bak llvmCtx mem0 llvmMod = do + -- allocate pointers values for function symbols, but do not + -- yet bind them to function handles + let decls = map Left (L.modDeclares llvmMod) ++ map Right (L.modDefines llvmMod) + + let allocLLVMFunPtr' bak' lctx mem decl = snd <$> allocLLVMFunPtr bak' lctx mem decl + foldM (allocLLVMFunPtr' bak llvmCtx) mem0 decls + +-- Not exported +someFnHandle :: FnHandle args ret -> SomeFnHandle +someFnHandle h = + case handleArgTypes h of + (_ Ctx.:> VectorRepr AnyRepr) -> VarargsFnHandle h + _ -> SomeFnHandle h + +-- | Look up an existing global function allocation by name and bind a handle +-- to it. +-- +-- This can overwrite existing allocation/handle associations, and is used to do +-- so when registering lazily-translated CFGs. +-- +-- For a stateful version in 'OverrideSim', see 'bindLLVMHandle'. +bindLLVMFunPtr :: + (IsSymBackend sym bak, HasPtrWidth wptr) => + bak -> + -- | Function name + L.Symbol -> + -- | Function implementation (CFG or override) + FnHandle args ret -> + -- | LLVM memory + MemImpl sym -> + IO (MemImpl sym) +bindLLVMFunPtr bak nm h mem = do + ptr <- doResolveGlobal bak mem nm + doInstallHandle bak ptr (someFnHandle h) mem + +-- | Look up an existing global function allocation by name and bind a handle +-- to it. +-- +-- This can overwrite existing allocation/handle associations, and is used to do +-- so when registering lazily-translated CFGs. +-- +-- For a less stateful version in 'IO', see 'bindLLVMHandle'. +bindLLVMHandle :: + (IsSymInterface sym, HasPtrWidth wptr) => + GlobalVar Mem -> + -- | Function name + L.Symbol -> + -- | Function handle + FnHandle args ret -> + -- | Function implementation (CFG or override) + FnState p sym ext args ret -> + OverrideSim p sym ext rtp l a () +bindLLVMHandle mvar nm hdl impl = do + OverrideSim.bindFnHandle hdl impl + mem <- OverrideSim.readGlobal mvar + mem' <- OverrideSim.ovrWithBackend $ \bak -> + liftIO (bindLLVMFunPtr bak nm hdl mem) + OverrideSim.writeGlobal mvar mem' + +-- | Look up an existing global function allocation by name and bind a CFG to +-- it. +-- +-- This can overwrite existing allocation/handle associations, and is used to do +-- so when registering lazily-translated CFGs. +bindLLVMCFG :: + (IsSymInterface sym, HasPtrWidth wptr) => + GlobalVar Mem -> + -- | Function name + L.Symbol -> + -- | Function CFG + CFG LLVM blocks init ret -> + OverrideSim p sym LLVM rtp l a () +bindLLVMCFG mvar name cfg = do + let h = cfgHandle cfg + s = UseCFG cfg (postdomInfo cfg) + bindLLVMHandle mvar name h s + +-- Private helper to make function handles +mkHandle :: + -- | Function name + L.Symbol -> + -- | Argument types + Ctx.Assignment TypeRepr args -> + -- | Return type + TypeRepr ret -> + OverrideSim p sym ext rtp l a (FnHandle args ret) +mkHandle nm args ret = do + let L.Symbol strNm = nm + let fnm = functionNameFromText (Text.pack strNm) + ctx <- use stateContext + let ha = simHandleAllocator ctx + liftIO $ mkHandle' ha fnm args ret + +-- | Create a function handle, then call 'bindLLVMHandle' on it. +bindLLVMFunc :: + (IsSymInterface sym, HasPtrWidth wptr) => + GlobalVar Mem -> + -- | Function name + L.Symbol -> + -- | Argument types + Ctx.Assignment TypeRepr args -> + -- | Return type + TypeRepr ret -> + -- | Function implementation (CFG or override) + FnState p sym ext args ret -> + OverrideSim p sym ext rtp l a () +bindLLVMFunc mvar nm args ret impl = do + hdl <- mkHandle nm args ret + bindLLVMHandle mvar nm hdl impl diff --git a/src/Lang/Crucible/LLVM/Globals.hs b/src/Lang/Crucible/LLVM/Globals.hs --- a/src/Lang/Crucible/LLVM/Globals.hs +++ b/src/Lang/Crucible/LLVM/Globals.hs @@ -36,7 +36,6 @@ , populateGlobals , populateAllGlobals , populateConstGlobals - , registerFunPtr , GlobalInitializerMap , makeGlobalMap @@ -47,7 +46,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Except (MonadError(..)) import Control.Lens hiding (op, (:>) ) -import Data.List (foldl') +import Data.List (foldl', genericLength, isPrefixOf) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -58,14 +57,13 @@ 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.Functions (allocLLVMFunPtrs) 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 @@ -109,7 +107,7 @@ => LLVMContext arch -> L.Module -> GlobalInitializerMap -makeGlobalMap ctx m = foldl' addAliases globalMap (Map.toList (llvmGlobalAliases ctx)) +makeGlobalMap ctx m = foldl' addAliases globalMap1 (Map.toList (llvmGlobalAliases ctx)) where addAliases mp (glob, aliases) = @@ -117,8 +115,9 @@ 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) + globalMap0 = Map.fromList $ map (\g -> (L.globalSym g, g)) (L.modGlobals m) + globalMap1 = Map.map (id &&& globalToConst) globalMap0 + loadRelConstInitMap = buildLoadRelConstInitMap globalMap0 m insertAll ks v mp = foldr (flip Map.insert v) mp ks @@ -137,11 +136,20 @@ => 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) + let (gty, mbGval) = + -- Check if a global variable was passed as an argument to + -- llvm.load.relative.i* (i.e., if it is reltable-like), and if + -- so, use an altered value for the constant initializer that uses + -- `bitcast`. See + -- Note [Undoing LLVM's relative table lookup conversion pass]. + case Map.lookup (L.globalSym g) loadRelConstInitMap of + Just (L.Typed constInitTy constInitVal) -> + (constInitTy, Just constInitVal) + Nothing -> + (L.globalType g, L.globalValue g) + mt <- liftMemType gty + mbVal <- traverse (transConstant' mt) mbGval + return (mt, mbVal) ------------------------------------------------------------------------- -- initializeMemory @@ -182,19 +190,39 @@ 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 pointers values for function symbols, but do not yet bind them to + -- function handles + mem <- allocLLVMFunPtrs bak llvm_ctx mem0 llvmModl -- Allocate global values let globAliases = llvmGlobalAliases llvm_ctx let globals = L.modGlobals llvmModl + let globalMap = Map.fromList $ map (\g -> (L.globalSym g, g)) globals + let loadRelConstInitMap = buildLoadRelConstInitMap globalMap 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 + -- Check if a global variable was passed as an argument + -- to llvm.load.relative.i* (i.e., if it is + -- reltable-like), and if so, use an altered type that + -- uses pointers instead of `i32`s. Also, do not use the + -- original global's alignment. See + -- Note [Undoing LLVM's relative table lookup conversion pass]. + (ty, mbGlobAlign) <- + case Map.lookup (L.globalSym g) loadRelConstInitMap of + Just constInit -> do + ty <- either err return $ + liftMemType $ + L.typedType constInit + -- Return Nothing for the alignment so that we + -- will instead use crucible-llvm's alignment + -- inference to compute the alignment of the + -- new constant initializer. + pure (ty, Nothing) + Nothing -> do + ty <- either err return $ liftMemType $ L.globalType g + pure (ty, L.globalAlign g) let sz = memTypeSize dl ty let tyAlign = memTypeAlign dl ty let aliases = map L.aliasName . Set.toList $ @@ -210,7 +238,7 @@ -- specified, the global is forced to have -- exactly that alignment. alignment <- - case L.globalAlign g of + case mbGlobAlign of Just a | a > 0 -> case toAlignment (toBytes a) of Nothing -> fail $ "Invalid alignemnt: " ++ show a ++ "\n " ++ @@ -222,47 +250,6 @@ 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 @@ -418,3 +405,213 @@ ptr <- doResolveGlobal bak mem (L.globalSym gl) (val, mem') <- runStateT (constToLLVMValP sym populateRec cval) mem storeConstRaw bak mem' ptr ty alignment val + +------------------------------------------------------------------------ +-- ** llvm.load.relative constant initializers + +-- | A map of global variable names ('L.Symbol's) that appear as arguments to +-- calls to the @llvm.load.relative.i*@ intrinsic. See +-- @Note [Undoing LLVM's relative table lookup conversion pass]@ for why we need +-- this. +type LoadRelConstInitMap = Map L.Symbol (L.Typed L.Value) + +-- | @buildLoadRelConstInitMap globalMap m@ takes a 'L.Module' (@m@) and a map +-- of global variable symbols to their definitions (@globalMap@) and computes +-- a 'LoadRelConstInitMap'. See +-- @Note [Undoing LLVM's relative table lookup conversion pass]@ for why we need +-- to do this. +buildLoadRelConstInitMap :: + Map L.Symbol L.Global -> + L.Module -> + LoadRelConstInitMap +buildLoadRelConstInitMap globalMap m = foldMap defineConstInits (L.modDefines m) + where + defineConstInits :: L.Define -> LoadRelConstInitMap + defineConstInits def = foldMap basicBlockConstInits (L.defBody def) + + basicBlockConstInits :: L.BasicBlock -> LoadRelConstInitMap + basicBlockConstInits bb = foldMap stmtConstInits (L.bbStmts bb) + + stmtConstInits :: L.Stmt -> LoadRelConstInitMap + stmtConstInits (L.Result _ instr _) = instrConstInits instr + stmtConstInits (L.Effect instr _) = instrConstInits instr + + instrConstInits :: L.Instr -> LoadRelConstInitMap + instrConstInits (L.Call _ _ (L.ValSymbol fun) [ptr, _offset]) + | L.Symbol funStr <- fun + , "llvm.load.relative.i" `isPrefixOf` funStr + , Just (gs, foldedConstTy, foldedConstInit) <- + foldLoadRelConstInit (L.typedValue ptr) + = Map.singleton gs (L.Typed foldedConstTy foldedConstInit) + instrConstInits _ = + Map.empty + + -- Check if the first argument to a call to llvm.load.relative.i* is + -- "reltable-like", and if so, return @Just (symb, ty, val)@, where: + -- + -- - @symb@ is the name of the global variable corresponding to the + -- argument. + -- + -- - @ty@ is the type of the global variable's new constant initializer. + -- + -- - @val@ is the new constant initializer value. + -- + -- See Note [Undoing LLVM's relative table lookup conversion pass] for an + -- explanation of what "reltable-like" means. + foldLoadRelConstInit :: L.Value -> Maybe (L.Symbol, L.Type, L.Value) + foldLoadRelConstInit (L.ValSymbol s) + | Just global <- Map.lookup s globalMap + , Just constInit <- L.globalValue global + -- Check that the type of the global variable is + -- [ x i32]. + , L.ValArray (L.PrimType (L.Integer 32)) constInitElems <- constInit + , Just foldedConstInitElems <- + traverse (foldLoadRelConstInitElem global) constInitElems + = Just ( L.globalSym global + , L.Array (genericLength constInitElems) ptrToI8Type + , L.ValArray ptrToI8Type foldedConstInitElems + ) + foldLoadRelConstInit (L.ValConstExpr (L.ConstConv L.BitCast tv _)) = + foldLoadRelConstInit (L.typedValue tv) + foldLoadRelConstInit _ = + Nothing + + -- Check that an element of a constant initializer is of the form + -- `trunc(ptrtoint x - ptrtoint p)`, and if so, return `Just x`. Otherwise, + -- return Nothing. + foldLoadRelConstInitElem :: L.Global -> L.Value -> Maybe L.Value + foldLoadRelConstInitElem global constInitElem + | L.ValConstExpr + (L.ConstConv L.Trunc + (L.Typed { L.typedValue = + L.ValConstExpr + (L.ConstArith + (L.Sub _ _) + (L.Typed { L.typedValue = + L.ValConstExpr (L.ConstConv L.PtrToInt x _) }) + (L.ValConstExpr (L.ConstConv L.PtrToInt p _))) }) + _truncTy) <- constInitElem + , L.ValSymbol pSym <- L.typedValue p + , L.globalSym global == pSym + = Just (L.ValConstExpr (L.ConstConv L.BitCast x ptrToI8Type)) + + | otherwise + = Nothing + + -- Type type i8*. + ptrToI8Type :: L.Type + ptrToI8Type = L.PtrTo $ L.PrimType $ L.Integer 8 + +{- +Note [Undoing LLVM's relative table lookup conversion pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Clang 14.0.0+ include a `rel-lookup-table-converter` optimization pass that is +enabled with -O1 or greater. This optimization usually applies to code that +looks like table lookups. For instance, this pass would take this C code: + + const char *F(int tag) { + static const char *const table[] = { + "A", + "B", + }; + + return table[tag]; + } + +And optimize it to LLVM bitcode that looks like this: + + @reltable.F = internal unnamed_addr constant [2 x i32] [i32 trunc (i64 sub (i64 ptrtoint ([2 x i8]* @.str to i64), i64 ptrtoint ([2 x i32]* @reltable.F to i64)) to i32), i32 trunc (i64 sub (i64 ptrtoint ([2 x i8]* @.str.1 to i64), i64 ptrtoint ([2 x i32]* @reltable.F to i64)) to i32)], align 4 + @.str = private unnamed_addr constant [2 x i8] c"A\00", align 1 + @.str.1 = private unnamed_addr constant [2 x i8] c"B\00", align 1 + + define dso_local i8* @F(i32 noundef %0) local_unnamed_addr #0 { + %2 = sext i32 %0 to i64 + %3 = shl i64 %2, 2 + %4 = call i8* @llvm.load.relative.i64(i8* bitcast ([2 x i32]* @reltable.F to i8*), i64 %3) + ret i8* %4 + } + +There are several remarkable things about this LLVM bitcode: + +* The definition of @F is backed up a relative lookup table @reltable.F. + Invoking @F is tantamount to looking up a value in the table by using the + special @llvm.load.relative.i* intrinsic, which is described here: + https://releases.llvm.org/17.0.1/docs/LangRef.html#llvm-load-relative-intrinsic + +* The definition of @reltable.F itself is quite unorthodox. Conceptually, it is + an array of strings (@.str and @.str1), but where each element of the array + contains the relative offset of the string to the table itself. As a result, + it is not an array of pointers, but rather an array of i32s! + +* Each i32 in the array consists of the address of each string represented as an + integer (obtained via ptrtoint) subtracted from the address of the table, + followed by a trunc to ensure the result fits in an i32. (One weird result of + this encoding is that @reltable.F is defined recursively in terms of itself.) + +This optimization pass is handy for Clang's purposes, as it allows Clang to +produce more efficient assembly code. Unfortunately, this encoding is quite +problematic for crucible-llvm. The problem ultimately lies in the fact that we +are performing pointer arithmetic on pointers from completely different +allocation regions (e.g., subtracting @reltable.F from @.str), which +crucible-llvm has no ability to reason about. (This optimization is also +problematic for CHERI, which tracks pointer provenance in a similar way—see +https://github.com/CTSRD-CHERI/llvm-project/issues/572). + +What's more, we don't have a reliable way of avoiding this optimization, as +Clang's optimization pass manager doesn't provide a way to disable individual +passes via command-line arguments. We could tell users to downgrade from -O1 +from -O0, but this would be a pretty severe workaround. + +Our solution is to manually "undo" the optimization ourselves. That is, we +replace the definition of @reltable.F with bitcode that looks like this: + + @reltable.F = internal unnamed_addr constant [2 x i8*] [i8* bitcast ([2 x i8]* @.str to i8*), i8* bitcast ([2 x i8]* @.str.1 to i8*)] + +This avoids any problematic uses of pointer arithmetic altogether. Here is how +we do this: + +1. When processing global definitions in an LLVM module, we identify the names + of all globals that are passed as the first argument to + @llvm.load.relative.i*. We'll refer to these as "reltable-like" globals. + + This check assumes that the globals are passed directly to + @llvm.load.relative.i*, rather than going through any intermediate + variables. This is likely a safe assumption to make, considering that + Clang's -O1 settings will usually optimize away any such intermediate + variables. + +2. For each reltable-like global, we check that the global has a constant + initializer of type [ x i32] where each element is of the form + `trunc (ptrtoint x - ptrtoint p)`. This is somewhat fragile, but the + documentation for llvm.load.relative.i* implies that LLVM itself checks + for code that looks like this, so we follow suit. + +3. For each element in the constant initializer array, we turn + `trunc (ptrtoint x - ptrtoint p)` into `bitcast x to i8*`. Note that the + this changes its type from `i32` to `i8*`. + +4. When translating a global definition to Crucible, we check if the global + is reltable-like. If so, we replace its constant initializer with the + `bitcast`ed version. We must also make sure that the global is translated + at type `[ x i8*]` rather than `[ x i32]`. + + Furthermore, we must also make sure not to use the original global's + alignment, as the `bitcast`ed version will almost certainly have different + alignment requirements. We rely on crucible-llvm's alignment inference to + figure out what the new alignment should be. + +5. In the override for llvm.load.relative.i*, we make sure to adjust the second + argument (the pointer offset). This is because LLVM assumes that the offset + is for something of type `[ x i32]`, so an offset value of 4 (four bytes) + refers to the first element, an offset value of 8 refers to the second + element, and so on. On the other hand, something of type `[ x i8*]` will + likely require different offsets, since the size of a pointer may be greater + than four bytes (e.g., it is eight bytes on 64-bit architectures). + + To account for this difference, we divide the offset value by 4 and then + multiply it by the number of bytes in the size of a pointer. + +It is worth emphasizing that this is a very ad hoc workaround. At the same time, +it is likely the best we can do without substantially changing how crucible-llvm +tracks pointer provenance. +-} diff --git a/src/Lang/Crucible/LLVM/Intrinsics.hs b/src/Lang/Crucible/LLVM/Intrinsics.hs --- a/src/Lang/Crucible/LLVM/Intrinsics.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics.hs @@ -29,21 +29,17 @@ , module Lang.Crucible.LLVM.Intrinsics.Common , module Lang.Crucible.LLVM.Intrinsics.Options +, module Lang.Crucible.LLVM.Intrinsics.Match ) where import Control.Lens hiding (op, (:>), Empty) -import Control.Monad (forM_) -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.Trans.Maybe -import Data.Foldable (asum) -import Data.List (stripPrefix, tails, isPrefixOf) +import Control.Monad (forM) +import Data.Maybe (catMaybes) 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 @@ -59,6 +55,7 @@ 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.Match import Lang.Crucible.LLVM.Intrinsics.Options llvmIntrinsicTypes :: IsSymInterface sym => IntrinsicTypes sym @@ -67,18 +64,22 @@ MapF.insert (knownSymbol :: SymbolRepr "LLVM_pointer") IntrinsicMuxFn $ MapF.empty --- | Register all declare and define overrides +-- | Match two sets of 'OverrideTemplate's against the @declare@s and @define@s +-- in a 'L.Module', registering all the overrides that apply and returning them +-- as a list. 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 -} -> + [OverrideTemplate p sym LLVM arch] {- ^ Additional \"define\" overrides -} -> + [OverrideTemplate p sym LLVM arch] {- ^ Additional \"declare\" overrides -} -> LLVMContext arch -> - OverrideSim p sym LLVM rtp l a () + -- | Applied (@define@ overrides, @declare@ overrides) + OverrideSim p sym LLVM rtp l a ([SomeLLVMOverride p sym LLVM], [SomeLLVMOverride p sym LLVM]) register_llvm_overrides llvmModule defineOvrs declareOvrs llvmctx = - do register_llvm_define_overrides llvmModule defineOvrs llvmctx - register_llvm_declare_overrides llvmModule declareOvrs llvmctx + do defOvs <- register_llvm_define_overrides llvmModule defineOvrs llvmctx + declOvs <- register_llvm_declare_overrides llvmModule declareOvrs llvmctx + pure (defOvs, declOvs) -- | Filter the initial list of templates to only those that could -- possibly match the given declaration based on straightforward, @@ -88,307 +89,100 @@ -- 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] -> + [OverrideTemplate p sym ext arch] -> 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 ] + [OverrideTemplate p sym ext arch] +filterTemplates ts decl = filter (matches nm . overrideTemplateMatcher) ts + where L.Symbol nm = L.decName decl +-- | Match a set of 'OverrideTemplate's against a single 'L.Declare', +-- registering all the overrides that apply and returning them as a list. +match_llvm_overrides :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMContext arch -> + -- | Overrides to attempt to match against this declaration + [OverrideTemplate p sym ext arch] -> + -- | Declaration of the function that might get overridden + L.Declare -> + OverrideSim p sym ext rtp l a [SomeLLVMOverride p sym ext] +match_llvm_overrides llvmctx acts decl = + llvmPtrWidth llvmctx $ \wptr -> withPtrWidth wptr $ do + let acts' = filterTemplates acts decl + let L.Symbol nm = L.decName decl + let declnm = either (const Nothing) Just $ ABI.demangleName nm + mbOvs <- + forM (map overrideTemplateAction acts') $ \(MakeOverride act) -> + case act decl declnm llvmctx of + Nothing -> pure Nothing + Just sov@(SomeLLVMOverride ov) -> do + register_llvm_override ov decl llvmctx + pure (Just sov) + pure (catMaybes mbOvs) --- | Helper function for registering overrides +-- | Match a set of 'OverrideTemplate's against a set of 'L.Declare's, +-- registering all the overrides that apply and returning them as a list. register_llvm_overrides_ :: + (IsSymInterface sym, HasLLVMAnn sym) => LLVMContext arch -> - [OverrideTemplate p sym arch rtp l a] -> + -- | Overrides to attempt to match against these declarations + [OverrideTemplate p sym ext arch] -> + -- | Declarations of the functions that might get overridden [L.Declare] -> - OverrideSim p sym LLVM rtp l a () + OverrideSim p sym ext rtp l a [SomeLLVMOverride p sym ext] 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')) + concat <$> forM decls (\decl -> match_llvm_overrides llvmctx acts decl) +-- | Match a set of 'OverrideTemplate's against all the @declare@s and @define@s +-- in a 'L.Module', registering all the overrides that apply and returning them +-- as a list. +-- +-- Registers a default set of overrides, in addition to the ones passed as an +-- argument. register_llvm_define_overrides :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch) => L.Module -> - [OverrideTemplate p sym arch rtp l a] -> + -- | Additional (non-default) @define@ overrides + [OverrideTemplate p sym LLVM arch] -> LLVMContext arch -> - OverrideSim p sym LLVM rtp l a () + OverrideSim p sym LLVM rtp l a [SomeLLVMOverride p sym LLVM] register_llvm_define_overrides llvmModule addlOvrs llvmctx = let ?lc = llvmctx^.llvmTypeCtx in register_llvm_overrides_ llvmctx (addlOvrs ++ define_overrides) $ (allModuleDeclares llvmModule) +-- | Match a set of 'OverrideTemplate's against all the @declare@s in a +-- 'L.Module', registering all the overrides that apply and returning them as +-- a list. +-- +-- Registers a default set of overrides, in addition to the ones passed as an +-- argument. 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] -> + -- | Additional (non-default) @declare@ overrides + [OverrideTemplate p sym LLVM arch] -> LLVMContext arch -> - OverrideSim p sym LLVM rtp l a () + OverrideSim p sym LLVM rtp l a [SomeLLVMOverride p sym LLVM] register_llvm_declare_overrides llvmModule addlOvrs llvmctx = let ?lc = llvmctx^.llvmTypeCtx in register_llvm_overrides_ llvmctx (addlOvrs ++ declare_overrides) $ L.modDeclares llvmModule - -- | 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] + [OverrideTemplate p sym LLVM arch] 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 + concat + [ map (\(SomeLLVMOverride ov) -> basic_llvm_override ov) Libc.libc_overrides + , map (\(SomeLLVMOverride ov) -> basic_llvm_override ov) LLVM.basic_llvm_overrides + , map (\(pfx, LLVM.Poly1LLVMOverride ov) -> polymorphic1_llvm_override pfx ov) LLVM.poly1_llvm_overrides + , map (\(pfx, LLVM.Poly1VecLLVMOverride ov) -> polymorphic1_vec_llvm_override pfx ov) LLVM.poly1_vec_llvm_overrides -- 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 + , [ Libcxx.register_cpp_override Libcxx.endlOverride ] ] @@ -396,7 +190,7 @@ -- function has a definition define_overrides :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?lc :: TypeContext) => - [OverrideTemplate p sym arch rtp l a] + [OverrideTemplate p sym LLVM arch] define_overrides = [ Libcxx.register_cpp_override Libcxx.putToOverride12 , Libcxx.register_cpp_override Libcxx.putToOverride9 diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs b/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Cast.hs @@ -0,0 +1,133 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Cast +-- Description : Cast between bitvectors and pointers in signatures +-- Copyright : (c) Galois, Inc 2024 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +-- +-- The built-in overrides in "Lang.Crucible.LLVM.Intrinsics.Libc" and +-- "Lang.Crucible.LLVM.Intrinsics.LLVM" frequently take arguments of type +-- 'Lang.Crucible.Types.BVType', but at runtime everything is represented as an +-- 'Lang.Crucible.LLVM.MemModel.Pointer.LLVMPtr'. This module contains helpers +-- for \"casting\" between pointers and bitvectors. +------------------------------------------------------------------------ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Lang.Crucible.LLVM.Intrinsics.Cast + ( ValCastError + , printValCastError + , ArgCast(applyArgCast) + , ValCast(applyValCast) + , castLLVMArgs + , castLLVMRet + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Lens +import qualified Data.Text as Text + +import qualified Data.Parameterized.Context as Ctx +import Data.Parameterized.Some (Some(Some)) +import Data.Parameterized.TraversableFC (fmapFC) + +import What4.FunctionName (FunctionName (functionName)) + +import Lang.Crucible.Backend +import Lang.Crucible.Simulator (SimErrorReason(AssertFailureSimError)) +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Types + +import Lang.Crucible.LLVM.MemModel.Partial (ptrToBv) +import Lang.Crucible.LLVM.MemModel.Pointer + +data ValCastError + = -- | Mismatched number of arguments ('castLLVMArgs') or struct fields + -- ('castLLVMRet'). + MismatchedShape + -- | Can\'t cast between these types + | ValCastError (Some TypeRepr) (Some TypeRepr) + +-- | Turn a 'ValCastError' into a human-readable message (lines). +printValCastError :: ValCastError -> [String] +printValCastError = + \case + MismatchedShape -> ["argument shape mismatch"] + ValCastError (Some ret) (Some ret') -> + [ "Cannot cast types" + , "*** Source type: " ++ show ret + , "*** Target type: " ++ show ret' + ] + +-- | A function to (infallibly) cast between 'Ctx.Assignment's of 'RegEntry's. +newtype ArgCast p sym ext args args' = + ArgCast { applyArgCast :: (forall rtp l a. + Ctx.Assignment (RegEntry sym) args -> + OverrideSim p sym ext rtp l a (Ctx.Assignment (RegEntry sym) args')) } + +-- | A function to (infallibly) cast a value of types @tp@ to @tp'@. +newtype ValCast p sym ext tp tp' = + ValCast { applyValCast :: (forall rtp l a. + RegValue sym tp -> + OverrideSim p sym ext rtp l a (RegValue sym tp')) } + +-- | Attempt to construct a function to cast between 'Ctx.Assignment's of +-- 'RegEntry's. +castLLVMArgs :: forall p sym ext bak args args'. + IsSymBackend sym bak => + -- | Only used in error messages + FunctionName -> + bak -> + CtxRepr args' -> + CtxRepr args -> + Either ValCastError (ArgCast p sym ext args args') +castLLVMArgs _fnm _ Ctx.Empty Ctx.Empty = + Right (ArgCast (\_ -> return Ctx.Empty)) +castLLVMArgs fnm bak (rest' Ctx.:> tp') (rest Ctx.:> tp) = + do ValCast f <- castLLVMRet fnm bak tp tp' + ArgCast fs <- castLLVMArgs fnm bak rest' rest + Right (ArgCast + (\(xs Ctx.:> x) -> do + xs' <- fs xs + x' <- f (regValue x) + pure (xs' Ctx.:> RegEntry tp' x'))) +castLLVMArgs _ _ _ _ = Left MismatchedShape + +-- | Attempt to construct a function to cast values of type @ret@ to type +-- @ret'@. +castLLVMRet :: + IsSymBackend sym bak => + -- | Only used in error messages + FunctionName -> + bak -> + TypeRepr ret -> + TypeRepr ret' -> + Either ValCastError (ValCast p sym ext ret ret') +castLLVMRet _fnm bak (BVRepr w) (LLVMPointerRepr w') + | Just Refl <- testEquality w w' + = Right (ValCast (liftIO . llvmPointer_bv (backendGetSym bak))) +castLLVMRet fnm bak (LLVMPointerRepr w) (BVRepr w') + | Just Refl <- testEquality w w' + = let err = + AssertFailureSimError + "Found a pointer where a bitvector was expected" + ("In the arguments or return value of" ++ Text.unpack (functionName fnm)) in + Right (ValCast (liftIO . ptrToBv bak err)) +castLLVMRet fnm bak (VectorRepr tp) (VectorRepr tp') + = do ValCast f <- castLLVMRet fnm bak tp tp' + Right (ValCast (traverse f)) +castLLVMRet fnm bak (StructRepr ctx) (StructRepr ctx') + = do ArgCast tf <- castLLVMArgs fnm bak ctx' ctx + Right (ValCast (\vals -> + let vals' = Ctx.zipWith (\tp (RV v) -> RegEntry tp v) ctx vals in + fmapFC (\x -> RV (regValue x)) <$> tf vals')) + +castLLVMRet _fnm _bak ret ret' + | Just Refl <- testEquality ret ret' + = Right (ValCast return) +castLLVMRet _fnm _bak ret ret' = Left (ValCastError (Some ret) (Some ret')) diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Common.hs b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Common.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Common.hs @@ -20,48 +20,42 @@ module Lang.Crucible.LLVM.Intrinsics.Common ( LLVMOverride(..) , SomeLLVMOverride(..) - , RegOverrideM + , MakeOverride(..) , llvmSizeT , llvmSSizeT , OverrideTemplate(..) - , TemplateMatcher(..) , callStackFromMemVar' -- ** register_llvm_override , basic_llvm_override , polymorphic1_llvm_override + , polymorphic1_vec_llvm_override , build_llvm_override , register_llvm_override , register_1arg_polymorphic_override - , bind_llvm_handle - , bind_llvm_func + , register_1arg_vec_polymorphic_override , 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 System.Info as Info 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 @@ -71,33 +65,37 @@ import Lang.Crucible.LLVM.Extension import Lang.Crucible.LLVM.Eval (callStackFromMemVar) -import Lang.Crucible.LLVM.Globals (registerFunPtr) +import Lang.Crucible.LLVM.Functions (registerFunPtr, bindLLVMFunc) import Lang.Crucible.LLVM.MemModel import Lang.Crucible.LLVM.MemModel.CallStack (CallStack) +import qualified Lang.Crucible.LLVM.Intrinsics.Cast as Cast +import qualified Lang.Crucible.LLVM.Intrinsics.Match as Match import Lang.Crucible.LLVM.Translation.Monad import Lang.Crucible.LLVM.Translation.Types -- | This type represents an implementation of an LLVM intrinsic function in -- Crucible. -data LLVMOverride p sym args ret = +-- +-- This is parameterized over @ext@ so that 'LLVMOverride's can more easily be +-- reused in the context of other language extensions that are also based on the +-- LLVM memory model, such as Macaw. +data LLVMOverride p sym ext args ret = LLVMOverride { llvmOverride_declare :: L.Declare -- ^ An LLVM name and signature for this intrinsic , llvmOverride_args :: CtxRepr args -- ^ A representation of the argument types , llvmOverride_ret :: TypeRepr ret -- ^ A representation of the return type , llvmOverride_def :: - 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) + IsSymInterface sym => + GlobalVar Mem -> + Ctx.Assignment (RegEntry sym) args -> + forall rtp args' ret'. + OverrideSim p sym ext 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) +data SomeLLVMOverride p sym ext = + forall args ret. SomeLLVMOverride (LLVMOverride p sym ext args ret) -- | Convenient LLVM representation of the @size_t@ type. llvmSizeT :: HasPtrWidth wptr => L.Type @@ -107,23 +105,31 @@ llvmSSizeT :: HasPtrWidth wptr => L.Type llvmSSizeT = L.PrimType $ L.Integer $ fromIntegral $ natValue $ PtrWidth -data OverrideTemplate p sym arch rtp l a = +-- | A funcion that inspects an LLVM declaration (along with some other data), +-- and constructs an override for the declaration if it can. +newtype MakeOverride p sym ext arch = + MakeOverride + { runMakeOverride :: + L.Declare -> + -- Decoded version of the name in the declaration + Maybe ABI.DecodedName -> + LLVMContext arch -> + Maybe (SomeLLVMOverride p sym ext) + } + +-- | Checking if an override applies to a given declaration happens in two +-- \"phases\", corresponding to the fields of this struct. +data OverrideTemplate p sym ext arch = OverrideTemplate - { overrideTemplateMatcher :: TemplateMatcher - , overrideTemplateAction :: RegOverrideM p sym arch rtp l a () + { -- | An initial, quick, string-based check if an override might apply to a + -- given declaration, based on its name + overrideTemplateMatcher :: Match.TemplateMatcher + -- | If the 'Match.TemplateMatcher' does indeed match, this slower + -- 'MakeOverride' performs additional checks and potentially constructs + -- a 'SomeLLVMOverride'. + , overrideTemplateAction :: MakeOverride p sym ext arch } --- | 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 @@ -132,74 +138,6 @@ ------------------------------------------------------------------------ -- ** 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@. @@ -210,50 +148,142 @@ TypeRepr ret -> CtxRepr args' -> TypeRepr ret' -> - (forall bak rtp' l' a'. IsSymBackend sym bak => - bak -> + (forall rtp' l' a'. IsSymInterface sym => 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') + OverrideSim p sym ext rtp' l' a' (RegValue sym ret)) -> + OverrideSim p sym ext rtp l a (Override p sym ext args' ret') build_llvm_override fnm args ret args' ret' llvmOverride = ovrWithBackend $ \bak -> - do fargs <- transformLLVMArgs fnm bak args args' - fret <- transformLLVMRet fnm bak ret ret' + do fargs <- + case Cast.castLLVMArgs fnm bak args args' of + Left err -> + panic "Intrinsics.build_llvm_override" + (Cast.printValCastError err ++ + [ "in function: " ++ Text.unpack (functionName fnm) ]) + Right f -> pure f + fret <- + case Cast.castLLVMRet fnm bak ret ret' of + Left err -> + panic "Intrinsics.build_llvm_override" + (Cast.printValCastError err ++ + [ "in function: " ++ Text.unpack (functionName fnm) ]) + Right f -> pure f return $ mkOverride' fnm ret' $ do RegMap xs <- getOverrideArgs - ovrWithBackend $ \bak' -> - applyValTransformer fret =<< llvmOverride bak' =<< applyArgTransformer fargs xs + Cast.applyValCast fret =<< llvmOverride =<< Cast.applyArgCast fargs xs -polymorphic1_llvm_override :: forall p sym arch wptr l a rtp. +polymorphic1_llvm_override :: forall p sym ext arch wptr. (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => String -> - (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) -> - OverrideTemplate p sym arch rtp l a + (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym ext) -> + OverrideTemplate p sym ext arch polymorphic1_llvm_override prefix fn = - OverrideTemplate (PrefixMatch prefix) (register_1arg_polymorphic_override prefix fn) + OverrideTemplate (Match.PrefixMatch prefix) (register_1arg_polymorphic_override prefix fn) -register_1arg_polymorphic_override :: forall p sym arch wptr l a rtp. +-- | Create an 'OverrideTemplate' for a polymorphic LLVM override involving +-- a vector type. For example, the @llvm.vector.reduce.add.*@ intrinsic can be +-- instantiated at multiple types, including: +-- +-- * @i32 \@llvm.vector.reduce.add.v4i32(<4 x i32>)@ +-- +-- * @i64 \@llvm.vector.reduce.add.v2i64(<2 x i64>)@ +-- +-- * etc. +-- +-- Note that the intrinsic can vary both by the size of the vector type (@4@, +-- @2@, etc.) and the size of the integer type used as the vector element type +-- (@i32@, @i64@, etc.) Therefore, the @fn@ argument that this function accepts +-- is parameterized by both the vector size (@vecSz@) and the integer size +-- (@intSz@). +polymorphic1_vec_llvm_override :: forall p sym ext arch wptr. (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => String -> - (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym) -> - RegOverrideM p sym arch rtp l a () + (forall vecSz intSz. + (1 <= intSz) => + NatRepr vecSz -> + NatRepr intSz -> + SomeLLVMOverride p sym ext) -> + OverrideTemplate p sym ext arch +polymorphic1_vec_llvm_override prefix fn = + OverrideTemplate (Match.PrefixMatch prefix) (register_1arg_vec_polymorphic_override prefix fn) + +register_1arg_polymorphic_override :: forall p sym ext arch wptr. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + String -> + (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym ext) -> + MakeOverride p sym ext arch register_1arg_polymorphic_override prefix overrideFn = - 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 + MakeOverride $ \(L.Declare{ L.decName = L.Symbol nm }) _ _ -> + case List.stripPrefix prefix nm of + Just ('.':'i': (readDec -> (sz,[]):_)) + | Some w <- mkNatRepr sz + , Just LeqProof <- isPosNat w + -> Just (overrideFn w) + _ -> Nothing -basic_llvm_override :: forall p args ret sym arch wptr l a rtp. +-- | Register a polymorphic LLVM override involving a vector type. (See the +-- Haddocks for 'polymorphic1_vec_llvm_override' for details on what this +-- means.) This function is responsible for parsing the suffix in the +-- intrinsic's name, which encodes the sizes of the vector and integer types. +-- As some examples: +-- +-- * @.v4i32@ (vector size @4@, integer size @32@) +-- +-- * @.v2i64@ (vector size @2@, integer size @64@) +register_1arg_vec_polymorphic_override :: forall p sym ext arch wptr. (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) + String -> + (forall vecSz intSz. + (1 <= intSz) => + NatRepr vecSz -> + NatRepr intSz -> + SomeLLVMOverride p sym ext) -> + MakeOverride p sym ext arch +register_1arg_vec_polymorphic_override prefix overrideFn = + MakeOverride $ \(L.Declare{ L.decName = L.Symbol nm }) _ _ -> + case List.stripPrefix prefix nm of + Just ('.':'v':suffix1) + | (vecSzStr, 'i':intSzStr) <- break (== 'i') suffix1 + , (vecSzNat, []):_ <- readDec vecSzStr + , (intSzNat, []):_ <- readDec intSzStr + , Some vecSzRepr <- mkNatRepr vecSzNat + , Some intSzRepr <- mkNatRepr intSzNat + , Just LeqProof <- isPosNat intSzRepr + -> Just (overrideFn vecSzRepr intSzRepr) + _ -> Nothing +basic_llvm_override :: forall p args ret sym ext arch wptr. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => + LLVMOverride p sym ext args ret -> + OverrideTemplate p sym ext arch +basic_llvm_override ovr = OverrideTemplate matcher regOvr + where + ovrDecl = llvmOverride_declare ovr + L.Symbol ovrNm = L.decName ovrDecl + isDarwin = Info.os == "darwin" + matcher :: Match.TemplateMatcher + matcher | isDarwin = Match.DarwinAliasMatch ovrNm + | otherwise = Match.ExactMatch ovrNm + + regOvr :: MakeOverride p sym ext arch + regOvr = do + MakeOverride $ \requestedDecl _ _ -> do + let L.Symbol requestedNm = L.decName requestedDecl + -- If we are on Darwin and the function name contains Darwin-specific + -- prefixes or suffixes, change the name of the override to the + -- name containing prefixes/suffixes. See Note [Darwin aliases] in + -- Lang.Crucible.LLVM.Intrinsics.Match for an explanation of why we + -- do this. + let ovr' | isDarwin + , ovrNm == Match.stripDarwinAliases requestedNm + = ovr { llvmOverride_declare = + ovrDecl { L.decName = L.Symbol requestedNm }} + + | otherwise + = ovr + Just (SomeLLVMOverride 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, @@ -277,60 +307,24 @@ 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. +register_llvm_override :: forall p args ret sym ext arch wptr rtp l a. (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 + LLVMOverride p sym ext args ret -> + L.Declare -> + LLVMContext arch -> + OverrideSim p sym ext rtp l a () +register_llvm_override llvmOverride requestedDecl llvmctx = do let decl = llvmOverride_declare llvmOverride if not (isMatchingDeclaration requestedDecl decl) then do when (L.decName requestedDecl == L.decName decl) $ - do logFn <- lift $ lift $ getLogFunction + do logFn <- 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 + else do_register_llvm_override llvmctx llvmOverride -- | Low-level function to register LLVM overrides. -- @@ -342,11 +336,11 @@ -- 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. +do_register_llvm_override :: forall p args ret sym ext 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 () + LLVMOverride p sym ext args ret -> + OverrideSim p sym ext rtp l a () do_register_llvm_override llvmctx llvmOverride = do let decl = llvmOverride_declare llvmOverride let (L.Symbol str_nm) = L.decName decl @@ -360,8 +354,8 @@ 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) + (\asgn -> llvmOverride_def llvmOverride mvar asgn) + bindLLVMFunc mvar (L.decName decl) args ret (UseOverride o) -- | Create an allocation for an override and register it. -- @@ -375,7 +369,7 @@ (IsSymBackend sym bak, HasPtrWidth wptr, HasLLVMAnn sym, ?memOpts :: MemOptions) => bak -> LLVMContext arch -> - LLVMOverride p sym args ret -> + LLVMOverride p sym LLVM args ret -> -- | Aliases [L.Symbol] -> OverrideSim p sym LLVM rtp l a () diff --git a/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/LLVM.hs @@ -51,1523 +51,2092 @@ 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 +import Lang.Crucible.LLVM.Bytes (Bytes(..), bitsToBytes) +import Lang.Crucible.LLVM.DataLayout (noAlignment) +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.QQ( llvmOvr ) +import Lang.Crucible.LLVM.Utils + +import Lang.Crucible.LLVM.Intrinsics.Common +import qualified Lang.Crucible.LLVM.Intrinsics.Libc as Libc +import Lang.Crucible.LLVM.TypeContext (TypeContext) + +-- | Local helper to make a null pointer in 'OverrideSim' +mkNull + :: (IsSymInterface sym, HasPtrWidth wptr) + => OverrideSim p sym ext rtp args ret (LLVMPtr sym wptr) +mkNull = do + sym <- getSymInterface + liftIO (mkNullPointer sym PtrWidth) + +------------------------------------------------------------------------ +-- ** Lists + +-- | All \"basic\"/\"monomorphic\" LLVM overrides. +-- +-- Can be turned into 'Lang.Crucible.LLVM.Intrinsics.Common.OverrideTemplate's +-- via 'Lang.Crucible.LLVM.Intrinsics.Common.basic_llvm_override'. +basic_llvm_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) => + [SomeLLVMOverride p sym ext] +basic_llvm_overrides = + [ SomeLLVMOverride llvmLifetimeStartOverride + , SomeLLVMOverride llvmLifetimeEndOverride + , SomeLLVMOverride (llvmLifetimeOverrideOverload "start" (knownNat @8)) + , SomeLLVMOverride (llvmLifetimeOverrideOverload "end" (knownNat @8)) + , SomeLLVMOverride (llvmLifetimeOverrideOverload_opaque "start") + , SomeLLVMOverride (llvmLifetimeOverrideOverload_opaque "end") + , SomeLLVMOverride (llvmInvariantStartOverride (knownNat @8)) + , SomeLLVMOverride llvmInvariantStartOverride_opaque + , SomeLLVMOverride (llvmInvariantEndOverride (knownNat @8)) + , SomeLLVMOverride llvmInvariantEndOverride_opaque + + , SomeLLVMOverride llvmAssumeOverride + , SomeLLVMOverride llvmTrapOverride + , SomeLLVMOverride llvmUBSanTrapOverride + + , SomeLLVMOverride llvmMemcpyOverride_8_8_32 + , SomeLLVMOverride llvmMemcpyOverride_8_8_32_noalign + , SomeLLVMOverride llvmMemcpyOverride_8_8_32_noalign_opaque + , SomeLLVMOverride llvmMemcpyOverride_8_8_64 + , SomeLLVMOverride llvmMemcpyOverride_8_8_64_noalign + , SomeLLVMOverride llvmMemcpyOverride_8_8_64_noalign_opaque + + , SomeLLVMOverride llvmMemmoveOverride_8_8_32 + , SomeLLVMOverride llvmMemmoveOverride_8_8_32_noalign + , SomeLLVMOverride llvmMemmoveOverride_8_8_32_noalign_opaque + , SomeLLVMOverride llvmMemmoveOverride_8_8_64 + , SomeLLVMOverride llvmMemmoveOverride_8_8_64_noalign + , SomeLLVMOverride llvmMemmoveOverride_8_8_64_noalign_opaque + + , SomeLLVMOverride llvmMemsetOverride_8_32 + , SomeLLVMOverride llvmMemsetOverride_8_32_noalign + , SomeLLVMOverride llvmMemsetOverride_8_32_noalign_opaque + , SomeLLVMOverride llvmMemsetOverride_8_64 + , SomeLLVMOverride llvmMemsetOverride_8_64_noalign + , SomeLLVMOverride llvmMemsetOverride_8_64_noalign_opaque + + , SomeLLVMOverride llvmObjectsizeOverride_32 + , SomeLLVMOverride llvmObjectsizeOverride_64 + + , SomeLLVMOverride llvmObjectsizeOverride_32_null + , SomeLLVMOverride llvmObjectsizeOverride_64_null + + , SomeLLVMOverride llvmObjectsizeOverride_32_null_dynamic + , SomeLLVMOverride llvmObjectsizeOverride_64_null_dynamic + + , SomeLLVMOverride llvmObjectsizeOverride_32_null_dynamic_opaque + , SomeLLVMOverride llvmObjectsizeOverride_64_null_dynamic_opaque + + , SomeLLVMOverride llvmPrefetchOverride + , SomeLLVMOverride llvmPrefetchOverride_opaque + , SomeLLVMOverride llvmPrefetchOverride_preLLVM10 + + , SomeLLVMOverride llvmStacksave + , SomeLLVMOverride llvmStackrestore + + , SomeLLVMOverride (llvmBSwapOverride (knownNat @2)) -- 16 = 2 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @4)) -- 32 = 4 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @6)) -- 48 = 6 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @8)) -- 64 = 8 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @10)) -- 80 = 10 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @12)) -- 96 = 12 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @14)) -- 112 = 14 * 8 + , SomeLLVMOverride (llvmBSwapOverride (knownNat @16)) -- 128 = 16 * 8 + + , SomeLLVMOverride llvmCopysignOverride_F32 + , SomeLLVMOverride llvmCopysignOverride_F64 + , SomeLLVMOverride llvmFabsF32 + , SomeLLVMOverride llvmFabsF64 + + , SomeLLVMOverride llvmCeilOverride_F32 + , SomeLLVMOverride llvmCeilOverride_F64 + , SomeLLVMOverride llvmFloorOverride_F32 + , SomeLLVMOverride llvmFloorOverride_F64 + , SomeLLVMOverride llvmSqrtOverride_F32 + , SomeLLVMOverride llvmSqrtOverride_F64 + , SomeLLVMOverride llvmSinOverride_F32 + , SomeLLVMOverride llvmSinOverride_F64 + , SomeLLVMOverride llvmCosOverride_F32 + , SomeLLVMOverride llvmCosOverride_F64 + , SomeLLVMOverride llvmPowOverride_F32 + , SomeLLVMOverride llvmPowOverride_F64 + , SomeLLVMOverride llvmExpOverride_F32 + , SomeLLVMOverride llvmExpOverride_F64 + , SomeLLVMOverride llvmLogOverride_F32 + , SomeLLVMOverride llvmLogOverride_F64 + , SomeLLVMOverride llvmExp2Override_F32 + , SomeLLVMOverride llvmExp2Override_F64 + , SomeLLVMOverride llvmLog2Override_F32 + , SomeLLVMOverride llvmLog2Override_F64 + , SomeLLVMOverride llvmLog10Override_F32 + , SomeLLVMOverride llvmLog10Override_F64 + , SomeLLVMOverride llvmFmaOverride_F32 + , SomeLLVMOverride llvmFmaOverride_F64 + , SomeLLVMOverride llvmFmuladdOverride_F32 + , SomeLLVMOverride llvmFmuladdOverride_F64 + , SomeLLVMOverride llvmIsFpclassOverride_F32 + , SomeLLVMOverride llvmIsFpclassOverride_F64 + + -- Some architecture-dependent intrinsics + , SomeLLVMOverride llvmX86_SSE2_storeu_dq + , SomeLLVMOverride llvmX86_pclmulqdq + ] + +-- | An LLVM override that is polymorphic in a single argument +newtype Poly1LLVMOverride p sym ext + = Poly1LLVMOverride (forall w. (1 <= w) => NatRepr w -> SomeLLVMOverride p sym ext) + +poly1_llvm_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) => + [(String, Poly1LLVMOverride p sym ext)] +poly1_llvm_overrides = + [ ("llvm.ctlz" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmCtlz w) + ) + , ("llvm.cttz" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmCttz w) + ) + , ("llvm.ctpop" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmCtpop w) + ) + , ("llvm.bitreverse" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmBitreverse w) + ) + , ("llvm.abs" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmAbsOverride w) + ) + + , ("llvm.fshl" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmFshl w) + ) + , ("llvm.fshr" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmFshr w) + ) + + , ("llvm.expect" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmExpectOverride w) + ) + , ("llvm.sadd.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmSaddWithOverflow w) + ) + , ("llvm.uadd.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmUaddWithOverflow w) + ) + , ("llvm.ssub.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmSsubWithOverflow w) + ) + , ("llvm.usub.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmUsubWithOverflow w) + ) + , ("llvm.smul.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmSmulWithOverflow w) + ) + , ("llvm.umul.with.overflow" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmUmulWithOverflow w) + ) + + , ("llvm.smax" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmSmax w) + ) + , ("llvm.smin" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmSmin w) + ) + , ("llvm.umax" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmUmax w) + ) + , ("llvm.umin" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmUmin w) + ) + + , ("llvm.load.relative" + , Poly1LLVMOverride $ \w -> SomeLLVMOverride (llvmLoadRelative w) + ) + ] + +-- | An LLVM override that is polymorphic in a single integer argument +-- (@intSz@) that is used in combination with a vector type, which can be of +-- varying sizes (@vecSz@). +newtype Poly1VecLLVMOverride p sym ext + = Poly1VecLLVMOverride + (forall vecSz intSz + . (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> SomeLLVMOverride p sym ext) + +poly1_vec_llvm_overrides :: + IsSymInterface sym => + [(String, Poly1VecLLVMOverride p sym ext)] +poly1_vec_llvm_overrides = + [ ("llvm.vector.reduce.add" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceAdd vecSz intSz) + ) + , ("llvm.vector.reduce.mul" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceMul vecSz intSz) + ) + , ("llvm.vector.reduce.and" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceAnd vecSz intSz) + ) + , ("llvm.vector.reduce.or" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceOr vecSz intSz) + ) + , ("llvm.vector.reduce.xor" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceXor vecSz intSz) + ) + , ("llvm.vector.reduce.smax" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceSmax vecSz intSz) + ) + , ("llvm.vector.reduce.smin" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceSmin vecSz intSz) + ) + , ("llvm.vector.reduce.umax" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceUmax vecSz intSz) + ) + , ("llvm.vector.reduce.umin" + , Poly1VecLLVMOverride $ \vecSz intSz -> + SomeLLVMOverride (llvmVectorReduceUmin vecSz intSz) + ) + ] + +------------------------------------------------------------------------ +-- ** 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 ext (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType +llvmLifetimeStartOverride = + [llvmOvr| void @llvm.lifetime.start( i64, i8* ) |] + (\_ops _args -> return ()) + +-- | See comment on 'llvmLifetimeStartOverride' +-- +-- +llvmLifetimeEndOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) UnitType +llvmLifetimeEndOverride = + [llvmOvr| void @llvm.lifetime.end( i64, i8* ) |] + (\_ops _args -> return ()) + +-- | This is a no-op. +-- +-- The language reference doesn't mention the use of this intrinsic. +llvmLifetimeOverrideOverload + :: forall width sym wptr p ext + . ( 1 <= width, KnownNat width + , IsSymInterface sym, HasPtrWidth wptr) + => String -- ^ "start" or "end" + -> NatRepr width + -> LLVMOverride p sym ext + (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 _args -> return ()) + +-- | Like 'llvmLifetimeOverrideOverload', but with an opaque pointer type. +llvmLifetimeOverrideOverload_opaque + :: forall sym wptr p ext + . (IsSymInterface sym, HasPtrWidth wptr) + => String -- ^ "start" or "end" + -> LLVMOverride p sym ext + (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 _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 ext + (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 _args -> mkNull) + +-- | Like 'llvmInvariantStartOverride', but with an opaque pointer type. +llvmInvariantStartOverride_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> BVType 64 ::> LLVMPointerType wptr) + (LLVMPointerType wptr) +llvmInvariantStartOverride_opaque = + let nm = L.Symbol "llvm.invariant.start.p0" in + [llvmOvr| {}* $nm ( i64, ptr ) |] + (\_ops _args -> mkNull) + +-- | See comment on 'llvmInvariantStartOverride'. +llvmInvariantEndOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => NatRepr width + -> LLVMOverride p sym ext + (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 _args -> return ()) + +-- | See comment on 'llvmInvariantStartOverride_opaque'. +llvmInvariantEndOverride_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 _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 ext + (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 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 ext (EmptyCtx ::> BVType 1) UnitType +llvmAssumeOverride = + [llvmOvr| void @llvm.assume ( i1 ) |] + (\_ops _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 ext EmptyCtx UnitType +llvmTrapOverride = + [llvmOvr| void @llvm.trap() |] + (\_ops _args -> + ovrWithBackend $ \bak -> + 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 ext (EmptyCtx ::> BVType 8) UnitType +llvmUBSanTrapOverride = + [llvmOvr| void @llvm.ubsantrap( i8 ) |] + (\_ops _args -> + ovrWithBackend $ \bak -> + liftIO $ addFailedAssertion bak $ AssertFailureSimError "llvm.ubsantrap() called" "") + +llvmStacksave + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext EmptyCtx (LLVMPointerType wptr) +llvmStacksave = + [llvmOvr| i8* @llvm.stacksave() |] + (\_memOps _args -> mkNull) + +llvmStackrestore + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) UnitType +llvmStackrestore = + [llvmOvr| void @llvm.stackrestore( i8* ) |] + (\_memOps _args -> return ()) + +llvmMemmoveOverride_8_8_32 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove memOps dst src len v) args) + +llvmMemmoveOverride_8_8_32_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemmove memOps) args) + +llvmMemmoveOverride_8_8_32_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemmove memOps) args) + + +llvmMemmoveOverride_8_8_64 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemmove memOps dst src len v) args) + +llvmMemmoveOverride_8_8_64_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemmove memOps) args) + +llvmMemmoveOverride_8_8_64_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (Libc.callMemmove memOps) args) + + +llvmMemsetOverride_8_64 + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset memOps dst val len v) args) + +llvmMemsetOverride_8_64_noalign + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemset memOps) args) + +llvmMemsetOverride_8_64_noalign_opaque + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemset memOps) args) + + +llvmMemsetOverride_8_32 + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst val len _align v -> Libc.callMemset memOps dst val len v) args) + +llvmMemsetOverride_8_32_noalign + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemset memOps) args) + +llvmMemsetOverride_8_32_noalign_opaque + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemset memOps) args) + + +llvmMemcpyOverride_8_8_32 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy memOps dst src len v) args) + +llvmMemcpyOverride_8_8_32_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemcpy memOps) args) + +llvmMemcpyOverride_8_8_32_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemcpy memOps) args) + + +llvmMemcpyOverride_8_8_64 + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> + Ctx.uncurryAssignment (\dst src len _align v -> Libc.callMemcpy memOps dst src len v) args) + +llvmMemcpyOverride_8_8_64_noalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemcpy memOps) args) + +llvmMemcpyOverride_8_8_64_noalign_opaque + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (Libc.callMemcpy memOps) args) + + +llvmObjectsizeOverride_32 + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32 = + [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1 ) |] + (\memOps args -> Ctx.uncurryAssignment (callObjectsize memOps knownNat) args) + +llvmObjectsizeOverride_32_null + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 32) +llvmObjectsizeOverride_32_null = + [llvmOvr| i32 @llvm.objectsize.i32.p0i8( i8*, i1, i1 ) |] + (\memOps args -> Ctx.uncurryAssignment (callObjectsize_null memOps knownNat) args) + +llvmObjectsizeOverride_32_null_dynamic + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (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 args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic memOps knownNat) args) + +llvmObjectsizeOverride_32_null_dynamic_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (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 args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic memOps knownNat) args) + +llvmObjectsizeOverride_64 + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64 = + [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1 ) |] + (\memOps args -> Ctx.uncurryAssignment (callObjectsize memOps knownNat) args) + +llvmObjectsizeOverride_64_null + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr ::> BVType 1 ::> BVType 1) (BVType 64) +llvmObjectsizeOverride_64_null = + [llvmOvr| i64 @llvm.objectsize.i64.p0i8( i8*, i1, i1 ) |] + (\memOps args -> Ctx.uncurryAssignment (callObjectsize_null memOps knownNat) args) + +llvmObjectsizeOverride_64_null_dynamic + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (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 args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic memOps knownNat) args) + +llvmObjectsizeOverride_64_null_dynamic_opaque + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (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 args -> Ctx.uncurryAssignment (callObjectsize_null_dynamic 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 ext + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride = + [llvmOvr| void @llvm.prefetch.p0i8( i8*, i32, i32, i32 ) |] + (\_memOps _args -> pure ()) + +-- | Like 'llvmPrefetchOverride', but with an opaque pointer type. +llvmPrefetchOverride_opaque :: + (IsSymInterface sym, HasPtrWidth wptr) => + LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride_opaque = + [llvmOvr| void @llvm.prefetch.p0( ptr, i32, i32, i32 ) |] + (\_memOps _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 ext + (EmptyCtx ::> LLVMPointerType wptr ::> BVType 32 ::> BVType 32 ::> BVType 32) + UnitType +llvmPrefetchOverride_preLLVM10 = + [llvmOvr| void @llvm.prefetch( i8*, i32, i32, i32 ) |] + (\_memOps _args -> pure ()) + +llvmFshl :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callFshl w) args) + +llvmFshr :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callFshr w) args) + +llvmSaddWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callSaddWithOverflow memOps) args) + +llvmUaddWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callUaddWithOverflow memOps) args) + + +llvmSsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callSsubWithOverflow memOps) args) + + +llvmUsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callUsubWithOverflow memOps) args) + +llvmSmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callSmulWithOverflow memOps) args) + +llvmUmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callUmulWithOverflow memOps) args) + +llvmUmax :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callUmax memOps) args) + +llvmUmin :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callUmin memOps) args) + +llvmSmax :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callSmax memOps) args) + +llvmSmin :: + (1 <= w, IsSymInterface sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callSmin memOps) args) + +llvmCtlz + :: (1 <= w, IsSymInterface sym) + => NatRepr w -> + LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callCtlz memOps) args) + +llvmCttz + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym ext + (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 args -> Ctx.uncurryAssignment (callCttz memOps) args) + +llvmCtpop + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym ext + (EmptyCtx ::> BVType w) + (BVType w) +llvmCtpop w = + let nm = L.Symbol ("llvm.ctpop.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w ) |] + (\memOps args -> Ctx.uncurryAssignment (callCtpop memOps) args) + +llvmBitreverse + :: (1 <= w, IsSymInterface sym) + => NatRepr w + -> LLVMOverride p sym ext + (EmptyCtx ::> BVType w) + (BVType w) +llvmBitreverse w = + let nm = L.Symbol ("llvm.bitreverse.i" ++ show (natValue w)) in + [llvmOvr| #w $nm( #w ) |] + (\memOps args -> Ctx.uncurryAssignment (callBitreverse memOps) args) + +-- | +llvmBSwapOverride + :: forall width sym p ext + . ( 1 <= width, IsSymInterface sym) + => NatRepr width + -> LLVMOverride p sym ext + (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 ) |] + (\_ args -> Ctx.uncurryAssignment (Libc.callBSwap widthRepr) args) + }}} + +-- | +llvmLoadRelative :: + ( 1 <= w + , HasPtrWidth wptr + , HasLLVMAnn sym + , ?memOpts :: MemOptions + ) => + NatRepr w -> + LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr ::> BVType w) + (LLVMPointerType wptr) +llvmLoadRelative w = + let nm = L.Symbol ("llvm.load.relative.i" ++ show (natValue w)) in + [llvmOvr| ptr $nm( ptr, #w ) |] + (\mvar args -> Ctx.uncurryAssignment (callLoadRelative mvar w) args) + +llvmAbsOverride :: + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + NatRepr w -> + LLVMOverride p sym ext + (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 args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (Libc.callLLVMAbs callStack w) args) + +llvmCopysignOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCopysignOverride_F32 = + [llvmOvr| float @llvm.copysign.f32( float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment callCopysign args) + +llvmCopysignOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCopysignOverride_F64 = + [llvmOvr| double @llvm.copysign.f64( double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment callCopysign args) + + +llvmFabsF32 + :: forall sym p ext + . ( IsSymInterface sym) + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFabsF32 = + [llvmOvr| float @llvm.fabs.f32( float ) |] + (\_memOps (Empty :> (regValue -> x)) -> do + sym <- getSymInterface + liftIO (iFloatAbs @_ @SingleFloat sym x)) + + +llvmFabsF64 + :: forall sym p ext + . ( IsSymInterface sym) + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFabsF64 = + [llvmOvr| double @llvm.fabs.f64( double ) |] + (\_memOps (Empty :> (regValue -> x)) -> do + sym <- getSymInterface + liftIO (iFloatAbs @_ @DoubleFloat sym x)) + +llvmCeilOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCeilOverride_F32 = + [llvmOvr| float @llvm.ceil.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callCeil args) + +llvmCeilOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCeilOverride_F64 = + [llvmOvr| double @llvm.ceil.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callCeil args) + +llvmFloorOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFloorOverride_F32 = + [llvmOvr| float @llvm.floor.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFloor args) + +llvmFloorOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFloorOverride_F64 = + [llvmOvr| double @llvm.floor.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFloor args) + +llvmSqrtOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSqrtOverride_F32 = + [llvmOvr| float @llvm.sqrt.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callSqrt args) + +llvmSqrtOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSqrtOverride_F64 = + [llvmOvr| double @llvm.sqrt.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callSqrt args) + +llvmSinOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinOverride_F32 = + [llvmOvr| float @llvm.sin.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Sin) args) + +llvmSinOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinOverride_F64 = + [llvmOvr| double @llvm.sin.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Sin) args) + +llvmCosOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCosOverride_F32 = + [llvmOvr| float @llvm.cos.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Cos) args) + +llvmCosOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCosOverride_F64 = + [llvmOvr| double @llvm.cos.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Cos) args) + +llvmPowOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmPowOverride_F32 = + [llvmOvr| float @llvm.pow.f32( float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 W4.Pow) args) + +llvmPowOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmPowOverride_F64 = + [llvmOvr| double @llvm.pow.f64( double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction2 W4.Pow) args) + +llvmExpOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpOverride_F32 = + [llvmOvr| float @llvm.exp.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Exp) args) + +llvmExpOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpOverride_F64 = + [llvmOvr| double @llvm.exp.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Exp) args) + +llvmLogOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLogOverride_F32 = + [llvmOvr| float @llvm.log.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log) args) + +llvmLogOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLogOverride_F64 = + [llvmOvr| double @llvm.log.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log) args) + +llvmExp2Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp2Override_F32 = + [llvmOvr| float @llvm.exp2.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Exp2) args) + +llvmExp2Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp2Override_F64 = + [llvmOvr| double @llvm.exp2.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Exp2) args) + +llvmLog2Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog2Override_F32 = + [llvmOvr| float @llvm.log2.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log2) args) + +llvmLog2Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog2Override_F64 = + [llvmOvr| double @llvm.log2.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log2) args) + +llvmLog10Override_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog10Override_F32 = + [llvmOvr| float @llvm.log10.f32( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log10) args) + +llvmLog10Override_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog10Override_F64 = + [llvmOvr| double @llvm.log10.f64( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (Libc.callSpecialFunction1 W4.Log10) args) + +llvmIsFpclassOverride_F32 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat + ::> BVType 32) + (BVType 1) +llvmIsFpclassOverride_F32 = + [llvmOvr| i1 @llvm.is.fpclass.f32( float, i32 ) |] + (\_memOps args -> Ctx.uncurryAssignment callIsFpclass args) + +llvmIsFpclassOverride_F64 :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat + ::> BVType 32) + (BVType 1) +llvmIsFpclassOverride_F64 = + [llvmOvr| i1 @llvm.is.fpclass.f64( double, i32 ) |] + (\_memOps args -> Ctx.uncurryAssignment callIsFpclass args) + +llvmFmaOverride_F32 :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmaOverride_F32 = + [llvmOvr| float @llvm.fma.f32( float, float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFMA args) + +llvmFmaOverride_F64 :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmaOverride_F64 = + [llvmOvr| double @llvm.fma.f64( double, double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFMA args) + +llvmFmuladdOverride_F32 :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmuladdOverride_F32 = + [llvmOvr| float @llvm.fmuladd.f32( float, float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFMA args) + +llvmFmuladdOverride_F64 :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmuladdOverride_F64 = + [llvmOvr| double @llvm.fmuladd.f64( double, double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment Libc.callFMA 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 ext + (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 args -> Ctx.uncurryAssignment (callX86_pclmulqdq memOps) args) + + +llvmX86_SSE2_storeu_dq + :: ( IsSymInterface sym + , HasLLVMAnn sym + , HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> VectorType (BVType 8)) + UnitType +llvmX86_SSE2_storeu_dq = + [llvmOvr| void @llvm.x86.sse2.storeu.dq( i8*, <16 x i8> ) |] + (\memOps args -> Ctx.uncurryAssignment (callStoreudq memOps) args) + + +-- | Build an 'LLVMOverride' for a vector reduce intrinsic. +llvmVectorReduce :: + (1 <= intSz) + => String + -- ^ The name of the operation to reduce (@add@, @mul@, etc.). + -> (forall r args ret + . IsSymInterface sym + => NatRepr intSz + -> RegEntry sym (VectorType (BVType intSz)) + -> OverrideSim p sym ext r args ret (SymBV sym intSz)) + -- ^ The semantics of the override. + -> NatRepr vecSz + -- ^ The size of the vector type. + -> NatRepr intSz + -- ^ The size of the integer type. + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduce opName callReduce vecSz intSz = + let nm = L.Symbol ("llvm.vector.reduce." ++ opName ++ + ".v" ++ show (natValue vecSz) ++ + "i" ++ show (natValue intSz)) in + [llvmOvr| #intSz $nm( <#vecSz x #intSz> ) |] + (\_memOps args -> Ctx.uncurryAssignment (callReduce intSz) args) + +llvmVectorReduceAdd :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceAdd = llvmVectorReduce "add" callVectorReduceAdd + +llvmVectorReduceMul :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceMul = llvmVectorReduce "mul" callVectorReduceMul + +llvmVectorReduceAnd :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceAnd = llvmVectorReduce "and" callVectorReduceAnd + +llvmVectorReduceOr :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceOr = llvmVectorReduce "or" callVectorReduceOr + +llvmVectorReduceXor :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceXor = llvmVectorReduce "xor" callVectorReduceXor + +llvmVectorReduceSmax :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceSmax = llvmVectorReduce "smax" callVectorReduceSmax + +llvmVectorReduceSmin :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceSmin = llvmVectorReduce "smin" callVectorReduceSmin + +llvmVectorReduceUmax :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceUmax = llvmVectorReduce "umax" callVectorReduceUmax + +llvmVectorReduceUmin :: + (1 <= intSz) + => NatRepr vecSz + -> NatRepr intSz + -> LLVMOverride p sym ext + (EmptyCtx ::> VectorType (BVType intSz)) + (BVType intSz) +llvmVectorReduceUmin = llvmVectorReduce "umin" callVectorReduceUmin + +------------------------------------------------------------------------ +-- ** Implementations + +callX86_pclmulqdq :: forall p sym ext wptr r args ret. + (IsSymInterface sym, HasPtrWidth wptr) => + 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 _mvar + (regValue -> xs) + (regValue -> ys) + (regValue -> imm) = + ovrWithBackend $ \bak -> 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 + let sym = backendGetSym bak + liftIO $ doPcmul sym (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 + + doPcmul :: sym -> SymBV sym 64 -> SymBV sym 64 -> IO (V.Vector (SymBV sym 64)) + doPcmul sym 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 + :: ( IsSymInterface sym + , HasLLVMAnn sym + , HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (VectorType (BVType 8)) + -> OverrideSim p sym ext r args ret () +callStoreudq mvar + (regValue -> dest) + (regValue -> vec) = + ovrWithBackend $ \bak -> 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, IsSymInterface sym) + => GlobalVar Mem + -> NatRepr w + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callObjectsize _mvar w + (regValue -> _ptr) + (regValue -> flag) = do + sym <- getSymInterface + liftIO $ do + -- 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 <- bvZero sym w + n <- bvNotBits sym z -- NB: -1 is the boolean negation of zero + bvIte sym t z n + +callObjectsize_null + :: (1 <= w, IsSymInterface sym) + => 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 mvar w ptr flag _nullUnknown = callObjectsize mvar w ptr flag + +callObjectsize_null_dynamic + :: (1 <= w, IsSymInterface sym) + => 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 mvar w ptr flag _nullUnknown (regValue -> dynamic) = + ovrWithBackend $ \bak -> 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 mvar w ptr flag + +callCtlz + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCtlz _mvar + (regValue -> val) + (regValue -> isZeroUndef) = + ovrWithBackend $ \bak -> do + sym <- getSymInterface + liftIO $ do + 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, IsSymInterface sym) + => 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 w x y amt = + ovrWithBackend $ \bak -> liftIO $ do + let sym = backendGetSym bak + LeqProof <- return (dblPosIsPos (leqProof (knownNat @1) w)) + Just LeqProof <- return (testLeq (addNat w (knownNat @1)) (addNat w w)) + + -- 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, IsSymInterface sym) + => 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 w x y amt = + ovrWithBackend $ \bak -> 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, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = + ovrWithBackend $ \bak -> 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, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + (ov, z) <- addUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + (ov, z) <- subUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callSsubWithOverflow + :: (1 <= w, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + (ov, z) <- subSignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callSmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + (ov, z) <- mulSignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUmulWithOverflow + :: (1 <= w, IsSymInterface sym) + => 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 _mvar + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + (ov, z) <- mulUnsignedOF sym x y + ov' <- predToBV sym ov (knownNat @1) + return (Empty :> RV z :> RV ov') + +callUmax + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callUmax _mvar (regValue -> x) (regValue -> y) = do + sym <- getSymInterface + liftIO $ bvUmax sym x y + +-- | Compute the unsigned maximum of two bitvectors. +bvUmax :: + (IsExprBuilder sym, 1 <= w) + => sym + -> SymBV sym w + -> SymBV sym w + -> IO (SymBV sym w) +bvUmax sym x y = do + xGtY <- bvUgt sym x y + bvIte sym xGtY x y + +callUmin + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callUmin _mvar (regValue -> x) (regValue -> y) = do + sym <- getSymInterface + liftIO $ bvUmin sym x y + +-- | Compute the unsigned minimum of two bitvectors. +bvUmin :: + (IsExprBuilder sym, 1 <= w) + => sym + -> SymBV sym w + -> SymBV sym w + -> IO (SymBV sym w) +bvUmin sym x y = do + xLtY <- bvUlt sym x y + bvIte sym xLtY x y + +callSmax + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callSmax _mvar (regValue -> x) (regValue -> y) = do + sym <- getSymInterface + liftIO $ bvSmax sym x y + +-- | Compute the signed maximum of two bitvectors. +bvSmax :: + (IsExprBuilder sym, 1 <= w) + => sym + -> SymBV sym w + -> SymBV sym w + -> IO (SymBV sym w) +bvSmax sym x y = do + xGtY <- bvSgt sym x y + bvIte sym xGtY x y + +callSmin + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callSmin _mvar (regValue -> x) (regValue -> y) = do + sym <- getSymInterface + liftIO $ bvSmin sym x y + +-- | Compute the signed minimum of two bitvectors. +bvSmin :: + (IsExprBuilder sym, 1 <= w) + => sym + -> SymBV sym w + -> SymBV sym w + -> IO (SymBV sym w) +bvSmin sym x y = do + xLtY <- bvSlt sym x y + bvIte sym xLtY x y + + +callCttz + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCttz _mvar + (regValue -> val) + (regValue -> isZeroUndef) = + ovrWithBackend $ \bak -> do + let sym = backendGetSym bak + liftIO $ do + 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, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callCtpop _mvar + (regValue -> val) = do + sym <- getSymInterface + liftIO $ bvPopcount sym val + +callBitreverse + :: (1 <= w, IsSymInterface sym) + => GlobalVar Mem + -> RegEntry sym (BVType w) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callBitreverse _mvar + (regValue -> val) = do + sym <- getSymInterface + liftIO $ bvBitreverse sym 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 ext r args ret. + IsSymInterface sym => + RegEntry sym (FloatType fi) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callCopysign + (regValue -> x) + (regValue -> y) = do + sym <- getSymInterface + liftIO $ do + 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 ext r args ret. + IsSymInterface sym => + RegEntry sym (FloatType fi) -> + RegEntry sym (BVType 32) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType 1)) +callIsFpclass regOp@(regValue -> op) (regValue -> test) = do + sym <- getSymInterface + let w1 = knownNat @1 + bv1 <- liftIO $ bvZero sym w1 + bv0 <- liftIO $ bvOne sym w1 + + let negative bit = liftIO $ do + isNeg <- iFloatIsNeg @_ @fi sym op + liftIO $ bvIte sym isNeg bit bv0 + + let positive bit = liftIO $ do + isPos <- iFloatIsPos @_ @fi sym op + liftIO $ bvIte sym isPos bit bv0 + + 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 bv1 bv0 + + let callIsNormal x = do + isNorm <- iFloatIsNorm @_ @fi sym x + bvIte sym isNorm bv1 bv0 + + let callIsSubnormal x = do + isSubnorm <- iFloatIsSubnorm @_ @fi sym x + bvIte sym isSubnorm bv1 bv0 + + let callIsZero x = do + is0 <- iFloatIsZero @_ @fi sym x + bvIte sym is0 bv1 bv0 + + isNan <- Libc.callIsnan 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 bv0 + liftIO $ bvOrBits sym newBit bits) + bv0 + [ (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 + ] + +-- | An override for the @llvm.load.relative.i*@ family of intrinsics. Broadly +-- speaking, this loads a pointer at from the first argument (a pointer to an +-- array) at the value of the second argument (the offset). However, due to the +-- reasons described in +-- @Note [Undoing LLVM's relative table lookup conversion pass]@ in +-- "Lang.Crucible.LLVM.Globals", this override adjusts the offset before +-- performing the load. +callLoadRelative :: + ( 1 <= w + , IsSymInterface sym + , HasPtrWidth wptr + , HasLLVMAnn sym + , ?memOpts :: MemOptions + ) => + GlobalVar Mem -> + NatRepr w -> + RegEntry sym (LLVMPointerType wptr) -> + RegEntry sym (BVType w) -> + OverrideSim p sym ext r args ret (LLVMPtr sym wptr) +callLoadRelative mvar w (regValue -> ptr) (regValue -> offsetInWords32) = do + mem <- readGlobal mvar + ovrWithBackend $ \bak -> liftIO $ do + let sym = backendGetSym bak + -- We cannot use the original offset value as-is because LLVM assumes that + -- it is loading an i32 value, but we have altered the first argument to + -- point to an array of i8*s instead, which may have different sizes. As + -- such, we adjust the offset value by (1) dividing it by 4 (the size of an + -- i32 value in bytes), and (2) multiplying it by the size of an i8*. + bvFour <- bvLit sym w $ BV.mkBV w 4 + offsetInElems <- bvUdiv sym offsetInWords32 bvFour + ptrWidthBytes <- + bvLit sym w $ + BV.uquot + (BV.mkBV w (intValue ?ptrWidth)) + (BV.mkBV w 8) + offsetInWordsPtrWidth <- + bvMul sym offsetInElems ptrWidthBytes + -- There is no guarantee that `wptr` is the same size as `w`, so we + -- sign-extend or truncate the offset (of size `w`) as needed to make it be + -- of size `wptr`. + offsetInWordsPtrWidth' <- + sextendBVTo sym w ?ptrWidth offsetInWordsPtrWidth + ptr' <- ptrAdd sym ?ptrWidth ptr offsetInWordsPtrWidth' + let ty = bitvectorType (bitsToBytes (natValue ?ptrWidth)) + doLoad bak mem ptr' ty PtrRepr noAlignment + +-- | The semantics of an LLVM vector reduce intrinsic. +callVectorReduce :: + -- | The operation which performs the reduction (e.g., addition, + -- multiplication, etc.) + (RegValue sym tp -> RegValue sym tp -> IO (RegValue sym tp)) -> + -- | The identity element for the reduction operation. (For addition, + -- this is @0@; for multiplication, this is @1@, and so on.) + RegValue sym tp -> + -- | The vector to reduce. + RegEntry sym (VectorType tp) -> + OverrideSim p sym ext r args ret (RegValue sym tp) +callVectorReduce reduceOp identityVal (regValue -> vec) = + liftIO $ V.foldM reduceOp identityVal vec + +callVectorReduceAdd :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceAdd intSz vec = do + sym <- getSymInterface + zero <- liftIO $ bvZero sym intSz + callVectorReduce (bvAdd sym) zero vec + +callVectorReduceMul :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceMul intSz vec = do + sym <- getSymInterface + one <- liftIO $ bvOne sym intSz + callVectorReduce (bvMul sym) one vec + +callVectorReduceAnd :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceAnd intSz vec = do + sym <- getSymInterface + zero <- liftIO $ bvZero sym intSz + ones <- liftIO $ bvNotBits sym zero + callVectorReduce (bvAndBits sym) ones vec + +callVectorReduceOr :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceOr intSz vec = do + sym <- getSymInterface + zero <- liftIO $ bvZero sym intSz + callVectorReduce (bvOrBits sym) zero vec + +callVectorReduceXor :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceXor intSz vec = do + sym <- getSymInterface + zero <- liftIO $ bvZero sym intSz + callVectorReduce (bvXorBits sym) zero vec + +callVectorReduceSmax :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceSmax intSz vec = do + sym <- getSymInterface + smin <- liftIO $ minSignedBV sym intSz + callVectorReduce (bvSmax sym) smin vec + +callVectorReduceSmin :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceSmin intSz vec = do + sym <- getSymInterface + smax <- liftIO $ maxSignedBV sym intSz + callVectorReduce (bvSmin sym) smax vec + +callVectorReduceUmax :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceUmax intSz vec = do + sym <- getSymInterface + umin <- liftIO $ minUnsignedBV sym intSz + callVectorReduce (bvUmax sym) umin vec + +callVectorReduceUmin :: + (IsSymInterface sym, 1 <= intSz) => + NatRepr intSz -> + RegEntry sym (VectorType (BVType intSz)) -> + OverrideSim p sym ext r args ret (SymBV sym intSz) +callVectorReduceUmin intSz vec = do + sym <- getSymInterface + umax <- liftIO $ maxUnsignedBV sym intSz + callVectorReduce (bvUmin sym) umax vec diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libc.hs @@ -43,1659 +43,1800 @@ 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)) +import What4.ProgramLoc (plSourceLoc) +import qualified What4.SpecialFunctions as W4 + +import Lang.Crucible.Backend +import Lang.Crucible.CFG.Common +import Lang.Crucible.Types +import Lang.Crucible.Simulator.ExecutionTree +import Lang.Crucible.Simulator.OverrideSim +import Lang.Crucible.Simulator.RegMap +import Lang.Crucible.Simulator.SimError + +import Lang.Crucible.LLVM.Bytes +import Lang.Crucible.LLVM.DataLayout +import qualified Lang.Crucible.LLVM.Errors.Poison as Poison +import qualified Lang.Crucible.LLVM.Errors.UndefinedBehavior as UB +import Lang.Crucible.LLVM.MalformedLLVMModule +import Lang.Crucible.LLVM.MemModel +import Lang.Crucible.LLVM.MemModel.CallStack (CallStack) +import qualified Lang.Crucible.LLVM.MemModel.Type as G +import qualified Lang.Crucible.LLVM.MemModel.Generic as G +import Lang.Crucible.LLVM.MemModel.Partial +import qualified Lang.Crucible.LLVM.MemModel.Pointer as Ptr +import Lang.Crucible.LLVM.Printf +import Lang.Crucible.LLVM.QQ( llvmOvr ) +import Lang.Crucible.LLVM.TypeContext + +import Lang.Crucible.LLVM.Intrinsics.Common +import Lang.Crucible.LLVM.Intrinsics.Options + +-- | All libc overrides. +-- +-- This list is useful to other Crucible frontends based on the LLVM memory +-- model (e.g., Macaw). +libc_overrides :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) => + [SomeLLVMOverride p sym ext] +libc_overrides = + [ SomeLLVMOverride llvmAbortOverride + , SomeLLVMOverride llvmAssertRtnOverride + , SomeLLVMOverride llvmAssertFailOverride + , SomeLLVMOverride llvmMemcpyOverride + , SomeLLVMOverride llvmMemcpyChkOverride + , SomeLLVMOverride llvmMemmoveOverride + , SomeLLVMOverride llvmMemsetOverride + , SomeLLVMOverride llvmMemsetChkOverride + , SomeLLVMOverride llvmMallocOverride + , SomeLLVMOverride llvmCallocOverride + , SomeLLVMOverride llvmFreeOverride + , SomeLLVMOverride llvmReallocOverride + , SomeLLVMOverride llvmStrlenOverride + , SomeLLVMOverride llvmPrintfOverride + , SomeLLVMOverride llvmPrintfChkOverride + , SomeLLVMOverride llvmPutsOverride + , SomeLLVMOverride llvmPutCharOverride + , SomeLLVMOverride llvmExitOverride + , SomeLLVMOverride llvmGetenvOverride + , SomeLLVMOverride llvmHtonlOverride + , SomeLLVMOverride llvmHtonsOverride + , SomeLLVMOverride llvmNtohlOverride + , SomeLLVMOverride llvmNtohsOverride + , SomeLLVMOverride llvmAbsOverride + , SomeLLVMOverride llvmLAbsOverride_32 + , SomeLLVMOverride llvmLAbsOverride_64 + , SomeLLVMOverride llvmLLAbsOverride + + , SomeLLVMOverride llvmCeilOverride + , SomeLLVMOverride llvmCeilfOverride + , SomeLLVMOverride llvmFloorOverride + , SomeLLVMOverride llvmFloorfOverride + , SomeLLVMOverride llvmFmaOverride + , SomeLLVMOverride llvmFmafOverride + , SomeLLVMOverride llvmIsinfOverride + , SomeLLVMOverride llvm__isinfOverride + , SomeLLVMOverride llvm__isinffOverride + , SomeLLVMOverride llvmIsnanOverride + , SomeLLVMOverride llvm__isnanOverride + , SomeLLVMOverride llvm__isnanfOverride + , SomeLLVMOverride llvm__isnandOverride + , SomeLLVMOverride llvmSqrtOverride + , SomeLLVMOverride llvmSqrtfOverride + , SomeLLVMOverride llvmSinOverride + , SomeLLVMOverride llvmSinfOverride + , SomeLLVMOverride llvmCosOverride + , SomeLLVMOverride llvmCosfOverride + , SomeLLVMOverride llvmTanOverride + , SomeLLVMOverride llvmTanfOverride + , SomeLLVMOverride llvmAsinOverride + , SomeLLVMOverride llvmAsinfOverride + , SomeLLVMOverride llvmAcosOverride + , SomeLLVMOverride llvmAcosfOverride + , SomeLLVMOverride llvmAtanOverride + , SomeLLVMOverride llvmAtanfOverride + , SomeLLVMOverride llvmSinhOverride + , SomeLLVMOverride llvmSinhfOverride + , SomeLLVMOverride llvmCoshOverride + , SomeLLVMOverride llvmCoshfOverride + , SomeLLVMOverride llvmTanhOverride + , SomeLLVMOverride llvmTanhfOverride + , SomeLLVMOverride llvmAsinhOverride + , SomeLLVMOverride llvmAsinhfOverride + , SomeLLVMOverride llvmAcoshOverride + , SomeLLVMOverride llvmAcoshfOverride + , SomeLLVMOverride llvmAtanhOverride + , SomeLLVMOverride llvmAtanhfOverride + , SomeLLVMOverride llvmHypotOverride + , SomeLLVMOverride llvmHypotfOverride + , SomeLLVMOverride llvmAtan2Override + , SomeLLVMOverride llvmAtan2fOverride + , SomeLLVMOverride llvmPowfOverride + , SomeLLVMOverride llvmPowOverride + , SomeLLVMOverride llvmExpOverride + , SomeLLVMOverride llvmExpfOverride + , SomeLLVMOverride llvmLogOverride + , SomeLLVMOverride llvmLogfOverride + , SomeLLVMOverride llvmExpm1Override + , SomeLLVMOverride llvmExpm1fOverride + , SomeLLVMOverride llvmLog1pOverride + , SomeLLVMOverride llvmLog1pfOverride + , SomeLLVMOverride llvmExp2Override + , SomeLLVMOverride llvmExp2fOverride + , SomeLLVMOverride llvmLog2Override + , SomeLLVMOverride llvmLog2fOverride + , SomeLLVMOverride llvmExp10Override + , SomeLLVMOverride llvmExp10fOverride + , SomeLLVMOverride llvm__exp10Override + , SomeLLVMOverride llvm__exp10fOverride + , SomeLLVMOverride llvmLog10Override + , SomeLLVMOverride llvmLog10fOverride + + , SomeLLVMOverride cxa_atexitOverride + , SomeLLVMOverride posixMemalignOverride + ] + +------------------------------------------------------------------------ +-- ** Declarations + + +llvmMemcpyOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemcpyOverride = + [llvmOvr| i8* @memcpy( i8*, i8*, size_t ) |] + (\memOps args -> + do sym <- getSymInterface + volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat + Ctx.uncurryAssignment (callMemcpy memOps) + (args :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + + +llvmMemcpyChkOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemcpyChkOverride = + [llvmOvr| i8* @__memcpy_chk ( i8*, i8*, size_t, size_t ) |] + (\memOps args -> + do let args' = Empty :> (args^._1) :> (args^._2) :> (args^._3) + sym <- getSymInterface + volatile <- liftIO $ RegEntry knownRepr <$> bvZero sym knownNat + Ctx.uncurryAssignment (callMemcpy memOps) + (args' :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + +llvmMemmoveOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> (LLVMPointerType wptr) + ::> (LLVMPointerType wptr) + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemmoveOverride = + [llvmOvr| i8* @memmove( i8*, i8*, size_t ) |] + (\memOps args -> + do sym <- getSymInterface + volatile <- liftIO (RegEntry knownRepr <$> bvZero sym knownNat) + Ctx.uncurryAssignment (callMemmove memOps) + (args :> volatile) + return $ regValue $ args^._1 -- return first argument + ) + +llvmMemsetOverride :: forall p sym ext wptr. + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 32 + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemsetOverride = + [llvmOvr| i8* @memset( i8*, i32, size_t ) |] + (\memOps args -> + do sym <- getSymInterface + LeqProof <- return (leqTrans @9 @16 @wptr LeqProof LeqProof) + let dest = args^._1 + val <- liftIO (RegEntry knownRepr <$> bvTrunc sym (knownNat @8) (regValue (args^._2))) + let len = args^._3 + volatile <- liftIO + (RegEntry knownRepr <$> bvZero sym knownNat) + callMemset memOps dest val len volatile + return (regValue dest) + ) + +llvmMemsetChkOverride + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType 32 + ::> BVType wptr + ::> BVType wptr) + (LLVMPointerType wptr) +llvmMemsetChkOverride = + [llvmOvr| i8* @__memset_chk( i8*, i32, size_t, size_t ) |] + (\memOps args -> + do sym <- getSymInterface + let dest = args^._1 + val <- liftIO + (RegEntry knownRepr <$> bvTrunc sym knownNat (regValue (args^._2))) + let len = args^._3 + volatile <- liftIO + (RegEntry knownRepr <$> bvZero sym knownNat) + callMemset memOps dest val len volatile + return (regValue dest) + ) + +------------------------------------------------------------------------ +-- *** Allocation + +llvmCallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> BVType wptr ::> BVType wptr) + (LLVMPointerType wptr) +llvmCallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @calloc( size_t, size_t ) |] + (\memOps args -> Ctx.uncurryAssignment (callCalloc memOps alignment) args) + + +llvmReallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr ::> BVType wptr) + (LLVMPointerType wptr) +llvmReallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @realloc( i8*, size_t ) |] + (\memOps args -> Ctx.uncurryAssignment (callRealloc memOps alignment) args) + +llvmMallocOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> BVType wptr) + (LLVMPointerType wptr) +llvmMallocOverride = + let alignment = maxAlignment (llvmDataLayout ?lc) in + [llvmOvr| i8* @malloc( size_t ) |] + (\memOps args -> Ctx.uncurryAssignment (callMalloc memOps alignment) args) + +posixMemalignOverride :: + ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) => + LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> BVType wptr + ::> BVType wptr) + (BVType 32) +posixMemalignOverride = + [llvmOvr| i32 @posix_memalign( i8**, size_t, size_t ) |] + (\memOps args -> Ctx.uncurryAssignment (callPosixMemalign memOps) args) + + +llvmFreeOverride + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr) + UnitType +llvmFreeOverride = + [llvmOvr| void @free( i8* ) |] + (\memOps args -> Ctx.uncurryAssignment (callFree memOps) args) + +------------------------------------------------------------------------ +-- *** Strings and I/O + +llvmPrintfOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> VectorType AnyType) + (BVType 32) +llvmPrintfOverride = + [llvmOvr| i32 @printf( i8*, ... ) |] + (\memOps args -> Ctx.uncurryAssignment (callPrintf memOps) args) + +llvmPrintfChkOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> BVType 32 + ::> LLVMPointerType wptr + ::> VectorType AnyType) + (BVType 32) +llvmPrintfChkOverride = + [llvmOvr| i32 @__printf_chk( i32, i8*, ... ) |] + (\memOps args -> Ctx.uncurryAssignment (\_flg -> callPrintf memOps) args) + + +llvmPutCharOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext (EmptyCtx ::> BVType 32) (BVType 32) +llvmPutCharOverride = + [llvmOvr| i32 @putchar( i32 ) |] + (\memOps args -> Ctx.uncurryAssignment (callPutChar memOps) args) + + +llvmPutsOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType 32) +llvmPutsOverride = + [llvmOvr| i32 @puts( i8* ) |] + (\memOps args -> Ctx.uncurryAssignment (callPuts memOps) args) + +llvmStrlenOverride + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => LLVMOverride p sym ext (EmptyCtx ::> LLVMPointerType wptr) (BVType wptr) +llvmStrlenOverride = + [llvmOvr| size_t @strlen( i8* ) |] + (\memOps args -> Ctx.uncurryAssignment (callStrlen memOps) args) + +------------------------------------------------------------------------ +-- ** Implementations + +------------------------------------------------------------------------ +-- *** Allocation + +callRealloc + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> Alignment + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callRealloc mvar alignment (regValue -> ptr) (regValue -> sz) = + ovrWithBackend $ \bak -> do + let sym = backendGetSym bak + szZero <- liftIO (notPred sym =<< bvIsNonzero sym sz) + ptrNull <- liftIO (ptrIsNull sym PtrWidth ptr) + loc <- liftIO (plSourceLoc <$> getCurrentProgramLoc sym) + let displayString = " " ++ show loc + + symbolicBranches emptyRegMap + -- If the pointer is null, behave like malloc + [ ( ptrNull + , modifyGlobal mvar $ \mem -> liftIO $ doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + , Nothing + ) + + -- If the size is zero, behave like malloc (of zero bytes) then free + , (szZero + , modifyGlobal mvar $ \mem -> liftIO $ + do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + mem2 <- doFree bak mem1 ptr + return (newp, mem2) + , Nothing + ) + + -- Otherwise, allocate a new region, memcopy `sz` bytes and free the old pointer + , (truePred sym + , modifyGlobal mvar $ \mem -> liftIO $ + do (newp, mem1) <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + mem2 <- uncheckedMemcpy sym mem1 newp ptr sz + mem3 <- doFree bak mem2 ptr + return (newp, mem3) + , Nothing) + ] + + +callPosixMemalign + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?lc :: TypeContext, ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPosixMemalign mvar (regValue -> outPtr) (regValue -> align) (regValue -> sz) = + ovrWithBackend $ \bak -> + let sym = backendGetSym bak in + case asBV align of + Nothing -> fail $ unwords ["posix_memalign: alignment value must be concrete:", show (printSymExpr align)] + Just concrete_align -> + case toAlignment (toBytes (BV.asUnsigned concrete_align)) of + Nothing -> fail $ unwords ["posix_memalign: invalid alignment value:", show concrete_align] + Just a -> + let dl = llvmDataLayout ?lc in + modifyGlobal mvar $ \mem -> liftIO $ + do loc <- plSourceLoc <$> getCurrentProgramLoc sym + let displayString = " " ++ show loc + (p, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz a + mem'' <- storeRaw bak mem' outPtr (bitvectorType (dl^.ptrSize)) (dl^.ptrAlign) (ptrToPtrVal p) + z <- bvZero sym knownNat + return (z, mem'') + +callMalloc + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> Alignment + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callMalloc mvar alignment (regValue -> sz) = + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + do loc <- plSourceLoc <$> getCurrentProgramLoc (backendGetSym bak) + let displayString = " " ++ show loc + doMalloc bak G.HeapAlloc G.Mutable displayString mem sz alignment + +callCalloc + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> Alignment + -> RegEntry sym (BVType wptr) + -> RegEntry sym (BVType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (LLVMPointerType wptr)) +callCalloc mvar alignment + (regValue -> sz) + (regValue -> num) = + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + doCalloc bak mem sz num alignment + +callFree + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret () +callFree mvar + (regValue -> ptr) = + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doFree bak mem ptr + return ((), mem') + +------------------------------------------------------------------------ +-- *** Memory manipulation + +callMemcpy + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemcpy mvar + (regValue -> dest) + (regValue -> src) + (RegEntry (BVRepr w) len) + _volatile = + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemcpy bak w mem True dest src len + return ((), mem') + +-- NB the only difference between memcpy and memove +-- is that memmove does not assert that the memory +-- ranges are disjoint. The underlying operation +-- works correctly in both cases. +callMemmove + :: ( IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemmove mvar + (regValue -> dest) + (regValue -> src) + (RegEntry (BVRepr w) len) + _volatile = + -- FIXME? add assertions about alignment + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemcpy bak w mem False dest src len + return ((), mem') + +callMemset + :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (BVType 8) + -> RegEntry sym (BVType w) + -> RegEntry sym (BVType 1) + -> OverrideSim p sym ext r args ret () +callMemset mvar + (regValue -> dest) + (regValue -> val) + (RegEntry (BVRepr w) len) + _volatile = + ovrWithBackend $ \bak -> + modifyGlobal mvar $ \mem -> liftIO $ + do mem' <- doMemset bak w mem dest val len + return ((), mem') + +------------------------------------------------------------------------ +-- *** Strings and I/O + +callPutChar + :: IsSymInterface sym + => GlobalVar Mem + -> RegEntry sym (BVType 32) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPutChar _mvar + (regValue -> ch) = do + h <- printHandle <$> getContext + let chval = maybe '?' (toEnum . fromInteger) (BV.asUnsigned <$> asBV ch) + liftIO $ hPutChar h chval + return ch + +callPuts + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPuts mvar + (regValue -> strPtr) = + ovrWithBackend $ \bak -> do + mem <- readGlobal mvar + str <- liftIO $ loadString bak mem strPtr Nothing + h <- printHandle <$> getContext + liftIO $ hPutStrLn h (UTF8.toString str) + -- return non-negative value on success + liftIO $ bvLit (backendGetSym bak) knownNat (BV.one knownNat) + +callStrlen + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType wptr)) +callStrlen mvar (regValue -> strPtr) = + ovrWithBackend $ \bak -> do + mem <- readGlobal mvar + liftIO $ strLen bak mem strPtr + +callAssert + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => GlobalVar Mem + -> Ctx.Assignment (RegEntry sym) + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + -> forall r args reg. + OverrideSim p sym ext r args reg (RegValue sym UnitType) +callAssert mvar (Empty :> _pfn :> _pfile :> _pline :> ptxt ) = + ovrWithBackend $ \bak -> do + let sym = backendGetSym bak + when failUponExit $ + do mem <- readGlobal mvar + txt <- liftIO $ loadString bak mem (regValue ptxt) Nothing + let err = AssertFailureSimError "Call to assert()" (UTF8.toString txt) + liftIO $ addFailedAssertion bak err + liftIO $ + do loc <- liftIO $ getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + where + failUponExit :: Bool + failUponExit + = abnormalExitBehavior ?intrinsicsOpts `elem` [AlwaysFail, OnlyAssertFail] + +callExit :: ( IsSymInterface sym + , ?intrinsicsOpts :: IntrinsicsOptions ) + => RegEntry sym (BVType 32) + -> OverrideSim p sym ext r args ret (RegValue sym UnitType) +callExit ec = + ovrWithBackend $ \bak -> liftIO $ do + let sym = backendGetSym bak + when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $ + do cond <- bvEq sym (regValue ec) =<< bvZero sym knownNat + -- If the argument is non-zero, throw an assertion failure. Otherwise, + -- simply stop the current thread of execution. + assert bak cond "Call to exit() with non-zero argument" + loc <- getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + +callPrintf + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?memOpts :: MemOptions ) + => GlobalVar Mem + -> RegEntry sym (LLVMPointerType wptr) + -> RegEntry sym (VectorType AnyType) + -> OverrideSim p sym ext r args ret (RegValue sym (BVType 32)) +callPrintf mvar + (regValue -> strPtr) + (regValue -> valist) = + ovrWithBackend $ \bak -> do + mem <- readGlobal mvar + formatStr <- liftIO $ loadString bak mem strPtr Nothing + case parseDirectives formatStr of + Left err -> overrideError $ AssertFailureSimError "Format string parsing failed" err + Right ds -> do + ((str, n), mem') <- liftIO $ runStateT (executeDirectives (printfOps bak valist) ds) mem + writeGlobal mvar mem' + h <- printHandle <$> getContext + liftIO $ BS.hPutStr h str + liftIO $ bvLit (backendGetSym bak) knownNat (BV.mkBV knownNat (toInteger n)) + +printfOps :: ( IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr + , ?memOpts :: MemOptions ) + => bak + -> V.Vector (AnyValue sym) + -> PrintfOperations (StateT (MemImpl sym) IO) +printfOps bak valist = + let sym = backendGetSym bak in + PrintfOperations + { printfUnsupported = \x -> lift $ addFailedAssertion bak + $ Unsupported GHC.callStack x + + , printfGetInteger = \i sgn _len -> + case valist V.!? (i-1) of + Just (AnyValue (LLVMPointerRepr w) p@(LLVMPointer _blk bv)) -> + do isBv <- liftIO (Ptr.ptrIsBv sym p) + liftIO $ assert bak isBv $ + AssertFailureSimError + "Passed a pointer to printf where a bitvector was expected" + "" + if sgn then + return $ BV.asSigned w <$> asBV bv + else + return $ BV.asUnsigned <$> asBV bv + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf" + (unwords ["Expected integer, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf" + (unwords ["Index:", show i]) + + , printfGetFloat = \i _len -> + case valist V.!? (i-1) of + Just (AnyValue (FloatRepr (_fi :: FloatInfoRepr fi)) x) -> + do xr <- liftIO (iFloatToReal @_ @fi sym x) + return (asRational xr) + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected floating-point, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfGetString = \i numchars -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + do mem <- get + liftIO $ loadString bak mem ptr numchars + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected char*, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfGetPointer = \i -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + return $ show (G.ppPtr ptr) + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected void*, but got:", show tpr]) + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + + , printfSetInteger = \i len v -> + case valist V.!? (i-1) of + Just (AnyValue PtrRepr ptr) -> + do mem <- get + case len of + Len_Byte -> do + let w8 = knownNat :: NatRepr 8 + let tp = G.bitvectorType 1 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w8 (BV.mkBV w8 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w8) tp noAlignment x + put mem' + Len_Short -> do + let w16 = knownNat :: NatRepr 16 + let tp = G.bitvectorType 2 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w16 (BV.mkBV w16 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w16) tp noAlignment x + put mem' + Len_NoMod -> do + let w32 = knownNat :: NatRepr 32 + let tp = G.bitvectorType 4 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w32 (BV.mkBV w32 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w32) tp noAlignment x + put mem' + Len_Long -> do + let w64 = knownNat :: NatRepr 64 + let tp = G.bitvectorType 8 + x <- liftIO (llvmPointer_bv sym =<< bvLit sym w64 (BV.mkBV w64 (toInteger v))) + mem' <- liftIO $ doStore bak mem ptr (LLVMPointerRepr w64) tp noAlignment x + put mem' + _ -> + lift $ addFailedAssertion bak + $ Unsupported GHC.callStack + $ unwords ["Unsupported size modifier in %n conversion:", show len] + + Just (AnyValue tpr _) -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Type mismatch in printf." + (unwords ["Expected void*, but got:", show tpr]) + + Nothing -> + lift $ addFailedAssertion bak + $ AssertFailureSimError + "Out-of-bounds argument access in printf:" + (unwords ["Index:", show i]) + } + +------------------------------------------------------------------------ +-- *** Math + +llvmCeilOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCeilOverride = + [llvmOvr| double @ceil( double ) |] + (\_memOps args -> Ctx.uncurryAssignment callCeil args) + +llvmCeilfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCeilfOverride = + [llvmOvr| float @ceilf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment callCeil args) + + +llvmFloorOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFloorOverride = + [llvmOvr| double @floor( double ) |] + (\_memOps args -> Ctx.uncurryAssignment callFloor args) + +llvmFloorfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFloorfOverride = + [llvmOvr| float @floorf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment callFloor args) + +llvmFmafOverride :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat + ::> FloatType SingleFloat + ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmFmafOverride = + [llvmOvr| float @fmaf( float, float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment callFMA args) + +llvmFmaOverride :: + forall sym p ext + . IsSymInterface sym + => LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat + ::> FloatType DoubleFloat + ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmFmaOverride = + [llvmOvr| double @fma( double, double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment callFMA args) + + +-- math.h defines isinf() and isnan() as macros, so you might think it unusual +-- to provide function overrides for them. However, if you write, say, +-- (isnan)(x) instead of isnan(x), Clang will compile the former as a direct +-- function call rather than as a macro application. Some experimentation +-- reveals that the isnan function's argument is always a double, so we give its +-- argument the type double here to match this unstated convention. We follow +-- suit similarly with isinf. +-- +-- Clang does not yet provide direct function call versions of isfinite() or +-- isnormal(), so we do not provide overrides for them. + +llvmIsinfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvmIsinfOverride = + [llvmOvr| i32 @isinf( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args) + +-- __isinf and __isinff are like the isinf macro, except their arguments are +-- known to be double or float, respectively. They are not mentioned in the +-- POSIX source standard, only the binary standard. See +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinf.html and +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isinff.html. +llvm__isinfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvm__isinfOverride = + [llvmOvr| i32 @__isinf( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args) + +llvm__isinffOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (BVType 32) +llvm__isinffOverride = + [llvmOvr| i32 @__isinff( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsinf (knownNat @32)) args) + +llvmIsnanOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvmIsnanOverride = + [llvmOvr| i32 @isnan( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args) + +-- __isnan and __isnanf are like the isnan macro, except their arguments are +-- known to be double or float, respectively. They are not mentioned in the +-- POSIX source standard, only the binary standard. See +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnan.html and +-- http://refspecs.linux-foundation.org/LSB_4.0.0/LSB-Core-generic/LSB-Core-generic/baselib---isnanf.html. +llvm__isnanOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvm__isnanOverride = + [llvmOvr| i32 @__isnan( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args) + +llvm__isnanfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (BVType 32) +llvm__isnanfOverride = + [llvmOvr| i32 @__isnanf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args) + +-- macOS compiles isnan() to __isnand() when the argument is a double. +llvm__isnandOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (BVType 32) +llvm__isnandOverride = + [llvmOvr| i32 @__isnand( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callIsnan (knownNat @32)) args) + +llvmSqrtOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSqrtOverride = + [llvmOvr| double @sqrt( double ) |] + (\_memOps args -> Ctx.uncurryAssignment callSqrt args) + +llvmSqrtfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSqrtfOverride = + [llvmOvr| float @sqrtf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment callSqrt args) + +callSpecialFunction1 :: + forall fi p sym ext r args ret. + (IsSymInterface sym, KnownRepr FloatInfoRepr fi) => + W4.SpecialFunction (EmptyCtx ::> W4.R) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSpecialFunction1 fn (regValue -> x) = do + sym <- getSymInterface + liftIO $ iFloatSpecialFunction1 sym (knownRepr :: FloatInfoRepr fi) fn x + +callSpecialFunction2 :: + forall fi p sym ext r args ret. + (IsSymInterface sym, KnownRepr FloatInfoRepr fi) => + W4.SpecialFunction (EmptyCtx ::> W4.R ::> W4.R) -> + RegEntry sym (FloatType fi) -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSpecialFunction2 fn (regValue -> x) (regValue -> y) = do + sym <- getSymInterface + liftIO $ iFloatSpecialFunction2 sym (knownRepr :: FloatInfoRepr fi) fn x y + +callCeil :: + forall fi p sym ext r args ret. + IsSymInterface sym => + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callCeil (regValue -> x) = do + sym <- getSymInterface + liftIO $ iFloatRound @_ @fi sym RTP x + +callFloor :: + forall fi p sym ext r args ret. + IsSymInterface sym => + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callFloor (regValue -> x) = do + sym <- getSymInterface + liftIO $ iFloatRound @_ @fi sym RTN x + +-- | An implementation of @libc@'s @fma@ function. +callFMA :: + forall fi p sym ext r args ret + . IsSymInterface sym + => RegEntry sym (FloatType fi) + -> RegEntry sym (FloatType fi) + -> RegEntry sym (FloatType fi) + -> OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callFMA (regValue -> x) (regValue -> y) (regValue -> z) = do + sym <- getSymInterface + liftIO $ iFloatFMA @_ @fi sym defaultRM x y z + +-- | An implementation of @libc@'s @isinf@ macro. This returns @1@ when the +-- argument is positive infinity, @-1@ when the argument is negative infinity, +-- and zero otherwise. +callIsinf :: + forall fi w p sym ext r args ret. + (IsSymInterface sym, 1 <= w) => + NatRepr w -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callIsinf w (regValue -> x) = do + sym <- getSymInterface + liftIO $ do + isInf <- iFloatIsInf @_ @fi sym x + isNeg <- iFloatIsNeg @_ @fi sym x + isPos <- iFloatIsPos @_ @fi sym x + isInfN <- andPred sym isInf isNeg + isInfP <- andPred sym isInf isPos + bv1 <- bvOne sym w + bvNeg1 <- bvNeg sym bv1 + bv0 <- bvZero sym w + res0 <- bvIte sym isInfP bv1 bv0 + bvIte sym isInfN bvNeg1 res0 + +callIsnan :: + forall fi w p sym ext r args ret. + (IsSymInterface sym, 1 <= w) => + NatRepr w -> + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callIsnan w (regValue -> x) = do + sym <- getSymInterface + liftIO $ do + isnan <- iFloatIsNaN @_ @fi sym x + bv1 <- bvOne sym w + bv0 <- bvZero sym w + -- isnan() is allowed to return any nonzero value if the argument is NaN, and + -- out of all the possible nonzero values, `1` is certainly one of them. + bvIte sym isnan bv1 bv0 + +callSqrt :: + forall fi p sym ext r args ret. + IsSymInterface sym => + RegEntry sym (FloatType fi) -> + OverrideSim p sym ext r args ret (RegValue sym (FloatType fi)) +callSqrt (regValue -> x) = do + sym <- getSymInterface + liftIO $ iFloatSqrt @_ @fi sym defaultRM x + +------------------------------------------------------------------------ +-- **** Circular trigonometry functions + +-- sin(f) + +llvmSinOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinOverride = + [llvmOvr| double @sin( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args) + +llvmSinfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinfOverride = + [llvmOvr| float @sinf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sin) args) + +-- cos(f) + +llvmCosOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCosOverride = + [llvmOvr| double @cos( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args) + +llvmCosfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCosfOverride = + [llvmOvr| float @cosf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cos) args) + +-- tan(f) + +llvmTanOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmTanOverride = + [llvmOvr| double @tan( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args) + +llvmTanfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmTanfOverride = + [llvmOvr| float @tanf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tan) args) + +-- asin(f) + +llvmAsinOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAsinOverride = + [llvmOvr| double @asin( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args) + +llvmAsinfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAsinfOverride = + [llvmOvr| float @asinf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsin) args) + +-- acos(f) + +llvmAcosOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAcosOverride = + [llvmOvr| double @acos( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args) + +llvmAcosfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAcosfOverride = + [llvmOvr| float @acosf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccos) args) + +-- atan(f) + +llvmAtanOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtanOverride = + [llvmOvr| double @atan( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args) + +llvmAtanfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtanfOverride = + [llvmOvr| float @atanf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctan) args) + +------------------------------------------------------------------------ +-- **** Hyperbolic trigonometry functions + +-- sinh(f) + +llvmSinhOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmSinhOverride = + [llvmOvr| double @sinh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args) + +llvmSinhfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmSinhfOverride = + [llvmOvr| float @sinhf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Sinh) args) + +-- cosh(f) + +llvmCoshOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmCoshOverride = + [llvmOvr| double @cosh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args) + +llvmCoshfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmCoshfOverride = + [llvmOvr| float @coshf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Cosh) args) + +-- tanh(f) + +llvmTanhOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmTanhOverride = + [llvmOvr| double @tanh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args) + +llvmTanhfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmTanhfOverride = + [llvmOvr| float @tanhf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Tanh) args) + +-- asinh(f) + +llvmAsinhOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAsinhOverride = + [llvmOvr| double @asinh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args) + +llvmAsinhfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAsinhfOverride = + [llvmOvr| float @asinhf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arcsinh) args) + +-- acosh(f) + +llvmAcoshOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAcoshOverride = + [llvmOvr| double @acosh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args) + +llvmAcoshfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAcoshfOverride = + [llvmOvr| float @acoshf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arccosh) args) + +-- atanh(f) + +llvmAtanhOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtanhOverride = + [llvmOvr| double @atanh( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args) + +llvmAtanhfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtanhfOverride = + [llvmOvr| float @atanhf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Arctanh) args) + +------------------------------------------------------------------------ +-- **** Rectangular to polar coordinate conversion + +-- hypot(f) + +llvmHypotOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmHypotOverride = + [llvmOvr| double @hypot( double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args) + +llvmHypotfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmHypotfOverride = + [llvmOvr| float @hypotf( float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Hypot) args) + +-- atan2(f) + +llvmAtan2Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmAtan2Override = + [llvmOvr| double @atan2( double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args) + +llvmAtan2fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmAtan2fOverride = + [llvmOvr| float @atan2f( float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Arctan2) args) + +------------------------------------------------------------------------ +-- **** Exponential and logarithm functions + +-- pow(f) + +llvmPowfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmPowfOverride = + [llvmOvr| float @powf( float, float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args) + +llvmPowOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmPowOverride = + [llvmOvr| double @pow( double, double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction2 W4.Pow) args) + +-- exp(f) + +llvmExpOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpOverride = + [llvmOvr| double @exp( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args) + +llvmExpfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpfOverride = + [llvmOvr| float @expf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp) args) + +-- log(f) + +llvmLogOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLogOverride = + [llvmOvr| double @log( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args) + +llvmLogfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLogfOverride = + [llvmOvr| float @logf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log) args) + +-- expm1(f) + +llvmExpm1Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExpm1Override = + [llvmOvr| double @expm1( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args) + +llvmExpm1fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExpm1fOverride = + [llvmOvr| float @expm1f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Expm1) args) + +-- log1p(f) + +llvmLog1pOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog1pOverride = + [llvmOvr| double @log1p( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args) + +llvmLog1pfOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog1pfOverride = + [llvmOvr| float @log1pf( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log1p) args) + +------------------------------------------------------------------------ +-- **** Base 2 exponential and logarithm + +-- exp2(f) + +llvmExp2Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp2Override = + [llvmOvr| double @exp2( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args) + +llvmExp2fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp2fOverride = + [llvmOvr| float @exp2f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp2) args) + +-- log2(f) + +llvmLog2Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog2Override = + [llvmOvr| double @log2( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args) + +llvmLog2fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog2fOverride = + [llvmOvr| float @log2f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log2) args) + +------------------------------------------------------------------------ +-- **** Base 10 exponential and logarithm + +-- exp10(f) + +llvmExp10Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmExp10Override = + [llvmOvr| double @exp10( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args) + +llvmExp10fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmExp10fOverride = + [llvmOvr| float @exp10f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args) + +-- macOS uses __exp10(f) instead of exp10(f). + +llvm__exp10Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvm__exp10Override = + [llvmOvr| double @__exp10( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args) + +llvm__exp10fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvm__exp10fOverride = + [llvmOvr| float @__exp10f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Exp10) args) + +-- log10(f) + +llvmLog10Override :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType DoubleFloat) + (FloatType DoubleFloat) +llvmLog10Override = + [llvmOvr| double @log10( double ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args) + +llvmLog10fOverride :: + IsSymInterface sym => + LLVMOverride p sym ext + (EmptyCtx ::> FloatType SingleFloat) + (FloatType SingleFloat) +llvmLog10fOverride = + [llvmOvr| float @log10f( float ) |] + (\_memOps args -> Ctx.uncurryAssignment (callSpecialFunction1 W4.Log10) args) + +------------------------------------------------------------------------ +-- *** Other + +-- from OSX libc +llvmAssertRtnOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + UnitType +llvmAssertRtnOverride = + [llvmOvr| void @__assert_rtn( i8*, i8*, i32, i8* ) |] + callAssert + +-- From glibc +llvmAssertFailOverride + :: ( IsSymInterface sym, HasPtrWidth wptr, HasLLVMAnn sym + , ?intrinsicsOpts :: IntrinsicsOptions, ?memOpts :: MemOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr + ::> LLVMPointerType wptr + ::> BVType 32 + ::> LLVMPointerType wptr) + UnitType +llvmAssertFailOverride = + [llvmOvr| void @__assert_fail( i8*, i8*, i32, i8* ) |] + callAssert + + +llvmAbortOverride + :: ( IsSymInterface sym + , ?intrinsicsOpts :: IntrinsicsOptions ) + => LLVMOverride p sym ext EmptyCtx UnitType +llvmAbortOverride = + [llvmOvr| void @abort() |] + (\_ _args -> + ovrWithBackend $ \bak -> liftIO $ do + let sym = backendGetSym bak + when (abnormalExitBehavior ?intrinsicsOpts == AlwaysFail) $ + let err = AssertFailureSimError "Call to abort" "" in + assert bak (falsePred sym) err + loc <- getCurrentProgramLoc sym + abortExecBecause $ EarlyExit loc + ) + +llvmExitOverride + :: forall sym p ext + . ( IsSymInterface sym + , ?intrinsicsOpts :: IntrinsicsOptions ) + => LLVMOverride p sym ext + (EmptyCtx ::> BVType 32) + UnitType +llvmExitOverride = + [llvmOvr| void @exit( i32 ) |] + (\_ args -> Ctx.uncurryAssignment callExit args) + +llvmGetenvOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr) + (LLVMPointerType wptr) +llvmGetenvOverride = + [llvmOvr| i8* @getenv( i8* ) |] + (\_ _args -> do + sym <- getSymInterface + liftIO $ mkNullPointer sym PtrWidth) + +llvmHtonlOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmHtonlOverride = + [llvmOvr| i32 @htonl( i32 ) |] + (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args) + +llvmHtonsOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 16) + (BVType 16) +llvmHtonsOverride = + [llvmOvr| i16 @htons( i16 ) |] + (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args) + +llvmNtohlOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmNtohlOverride = + [llvmOvr| i32 @ntohl( i32 ) |] + (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @4)) args) + +llvmNtohsOverride :: + (IsSymInterface sym, ?lc :: TypeContext) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 16) + (BVType 16) +llvmNtohsOverride = + [llvmOvr| i16 @ntohs( i16 ) |] + (\_memOps args -> Ctx.uncurryAssignment (callBSwapIfLittleEndian (knownNat @2)) args) + +llvmAbsOverride :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmAbsOverride = + [llvmOvr| i32 @abs( i32 ) |] + (\mvar args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @32)) args) + +-- @labs@ uses `long` as its argument and result type, so we need two overrides +-- for @labs@. See Note [Overrides involving (unsigned) long] in +-- Lang.Crucible.LLVM.Intrinsics. +llvmLAbsOverride_32 :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 32) + (BVType 32) +llvmLAbsOverride_32 = + [llvmOvr| i32 @labs( i32 ) |] + (\mvar args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @32)) args) + +llvmLAbsOverride_64 :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 64) + (BVType 64) +llvmLAbsOverride_64 = + [llvmOvr| i64 @labs( i64 ) |] + (\mvar args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args) + +llvmLLAbsOverride :: + (IsSymInterface sym, HasLLVMAnn sym) => + LLVMOverride p sym ext + (EmptyCtx ::> BVType 64) + (BVType 64) +llvmLLAbsOverride = + [llvmOvr| i64 @llabs( i64 ) |] + (\mvar args -> + do callStack <- callStackFromMemVar' mvar + Ctx.uncurryAssignment (callLibcAbs callStack (knownNat @64)) args) + +callBSwap :: + (1 <= width, IsSymInterface sym) => + NatRepr width -> + RegEntry sym (BVType (width * 8)) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8))) +callBSwap widthRepr (regValue -> vec) = do + sym <- getSymInterface + liftIO $ bvSwap sym widthRepr vec + +-- | This determines under what circumstances @callAbs@ should check if its +-- argument is equal to the smallest signed integer of a particular size +-- (e.g., @INT_MIN@), and if it is equal to that value, what kind of error +-- should be reported. +data CheckAbsIntMin + = LibcAbsIntMinUB + -- ^ For the @abs@, @labs@, and @llabs@ functions, always check if the + -- argument is equal to @INT_MIN@. If so, report it as undefined + -- behavior per the C standard. + | LLVMAbsIntMinPoison Bool + -- ^ For the @llvm.abs.*@ family of LLVM intrinsics, check if the argument + -- is equal to @INT_MIN@ only when the 'Bool' argument is 'True'. If it + -- is 'True' and the argument is equal to @INT_MIN@, return poison. + +-- | The workhorse for the @abs@, @labs@, and @llabs@ functions, as well as the +-- @llvm.abs.*@ family of overloaded intrinsics. +callAbs :: + forall w p sym ext r args ret. + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + CallStack -> + CheckAbsIntMin -> + NatRepr w -> + RegEntry sym (BVType w) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callAbs callStack checkIntMin widthRepr (regValue -> src) = do + sym <- getSymInterface + ovrWithBackend $ \bak -> liftIO $ do + bvIntMin <- bvLit sym widthRepr (BV.minSigned widthRepr) + isNotIntMin <- notPred sym =<< bvEq sym src bvIntMin + + when shouldCheckIntMin $ do + isNotIntMinUB <- annotateUB sym callStack ub isNotIntMin + let err = AssertFailureSimError "Undefined behavior encountered" $ + show $ UB.explain ub + assert bak isNotIntMinUB err + + isSrcNegative <- bvIsNeg sym src + srcNegated <- bvNeg sym src + bvIte sym isSrcNegative srcNegated src + where + shouldCheckIntMin :: Bool + shouldCheckIntMin = + case checkIntMin of + LibcAbsIntMinUB -> True + LLVMAbsIntMinPoison shouldCheck -> shouldCheck + + ub :: UB.UndefinedBehavior (RegValue' sym) + ub = case checkIntMin of + LibcAbsIntMinUB -> + UB.AbsIntMin $ RV src + LLVMAbsIntMinPoison{} -> + UB.PoisonValueCreated $ Poison.LLVMAbsIntMin $ RV src + +callLibcAbs :: + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + CallStack -> + NatRepr w -> + RegEntry sym (BVType w) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callLibcAbs callStack = callAbs callStack LibcAbsIntMinUB + +callLLVMAbs :: + (1 <= w, IsSymInterface sym, HasLLVMAnn sym) => + CallStack -> + NatRepr w -> + RegEntry sym (BVType w) -> + RegEntry sym (BVType 1) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType w)) +callLLVMAbs callStack widthRepr src (regValue -> isIntMinPoison) = do + shouldCheckIntMin <- liftIO $ + -- Per https://releases.llvm.org/12.0.0/docs/LangRef.html#id451, the second + -- argument must be a constant. + case asBV isIntMinPoison of + Just bv -> pure (bv /= BV.zero (knownNat @1)) + Nothing -> malformedLLVMModule + "Call to llvm.abs.* with non-constant second argument" + [printSymExpr isIntMinPoison] + callAbs callStack (LLVMAbsIntMinPoison shouldCheckIntMin) widthRepr src + +-- | If the data layout is little-endian, run 'callBSwap' on the input. +-- Otherwise, return the input unchanged. This is the workhorse for the +-- @hton{s,l}@ and @ntoh{s,l}@ overrides. +callBSwapIfLittleEndian :: + (1 <= width, IsSymInterface sym, ?lc :: TypeContext) => + NatRepr width -> + RegEntry sym (BVType (width * 8)) -> + OverrideSim p sym ext r args ret (RegValue sym (BVType (width * 8))) +callBSwapIfLittleEndian widthRepr vec = + case (llvmDataLayout ?lc)^.intLayout of + BigEndian -> pure (regValue vec) + LittleEndian -> callBSwap widthRepr vec + +---------------------------------------------------------------------------- +-- atexit stuff + +cxa_atexitOverride + :: (IsSymInterface sym, HasPtrWidth wptr) + => LLVMOverride p sym ext + (EmptyCtx ::> LLVMPointerType wptr ::> LLVMPointerType wptr ::> LLVMPointerType wptr) + (BVType 32) +cxa_atexitOverride = + [llvmOvr| i32 @__cxa_atexit( void (i8*)*, i8*, i8* ) |] + (\_ _args -> do + sym <- getSymInterface + liftIO $ bvZero sym knownNat) ---------------------------------------------------------------------------- diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Libcxx.hs @@ -35,7 +35,6 @@ ) where import qualified ABI.Itanium as ABI -import Control.Applicative (empty) import Control.Lens ((^.)) import Control.Monad.Reader import Data.List (isInfixOf) @@ -50,12 +49,14 @@ import Lang.Crucible.Backend import Lang.Crucible.CFG.Common (GlobalVar) +import Lang.Crucible.Simulator.OverrideSim (getSymInterface) import Lang.Crucible.Simulator.RegMap (RegValue, regValue) import Lang.Crucible.Panic (panic) import Lang.Crucible.Types (TypeRepr(UnitRepr), CtxRepr) import Lang.Crucible.LLVM.Extension import Lang.Crucible.LLVM.Intrinsics.Common +import qualified Lang.Crucible.LLVM.Intrinsics.Match as Match import Lang.Crucible.LLVM.MemModel import Lang.Crucible.LLVM.Translation.Monad import Lang.Crucible.LLVM.Translation.Types @@ -68,16 +69,12 @@ register_cpp_override :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => SomeCPPOverride p sym arch -> - OverrideTemplate p sym arch rtp l a + OverrideTemplate p sym LLVM arch 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 + OverrideTemplate (Match.SubstringsMatch ("_Z" : cppOverrideSubstrings someCPPOverride)) $ + MakeOverride $ \requestedDecl decName llvmctx -> do + nm <- decName + cppOverrideAction someCPPOverride requestedDecl nm llvmctx -- type CPPOverride p sym arch args ret = @@ -89,7 +86,7 @@ data SomeCPPOverride p sym arch = SomeCPPOverride { cppOverrideSubstrings :: [String] - , cppOverrideAction :: L.Declare -> ABI.DecodedName -> LLVMContext arch -> Maybe (SomeLLVMOverride p sym) + , cppOverrideAction :: L.Declare -> ABI.DecodedName -> LLVMContext arch -> Maybe (SomeLLVMOverride p sym LLVM) } ------------------------------------------------------------------------ @@ -126,7 +123,7 @@ -- 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)) + -> (forall args ret. L.Declare -> CtxRepr args -> TypeRepr ret -> Maybe (SomeLLVMOverride p sym LLVM)) -> (L.Symbol -> ABI.DecodedName -> Bool) -> SomeCPPOverride p sym arch mkOverride substrings ov filt = @@ -147,7 +144,7 @@ voidOverride substrings = mkOverride substrings $ \decl argTys retTy -> Just $ case retTy of - UnitRepr -> SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym _args -> pure () + UnitRepr -> SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _args -> pure () _ -> panic_ "voidOverride" decl argTys retTy -- | Make an override for a function of (LLVM) type @a -> a@, for any @a@. @@ -162,7 +159,7 @@ case argTys of (Ctx.Empty Ctx.:> argTy) | Just Refl <- testEquality argTy retTy -> - SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args -> + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem args -> -- Just return the input pure (Ctx.uncurryAssignment regValue args) @@ -180,7 +177,7 @@ case argTys of (Ctx.Empty Ctx.:> fstTy Ctx.:> _) | Just Refl <- testEquality fstTy retTy -> - SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem _sym args -> + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \_mem args -> pure (Ctx.uncurryAssignment (const . regValue) args) _ -> panic_ "constOverride" decl argTys retTy @@ -196,8 +193,9 @@ 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)) + SomeLLVMOverride $ LLVMOverride decl argTys retTy $ \mem _args -> do + sym <- getSymInterface + liftIO (regval mem sym) _ -> panic_ "fixedOverride" decl argTys retTy diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Match.hs b/src/Lang/Crucible/LLVM/Intrinsics/Match.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/Intrinsics/Match.hs @@ -0,0 +1,109 @@ +-- | +-- Module : Lang.Crucible.LLVM.Intrinsics.Match +-- Description : Matching overrides to function names +-- Copyright : (c) Galois, Inc 2024 +-- License : BSD3 +-- Maintainer : Langston Barrett +-- Stability : provisional +------------------------------------------------------------------------ + +module Lang.Crucible.LLVM.Intrinsics.Match + ( TemplateMatcher(..) + , matches + , stripDarwinAliases + ) where + +import Control.Applicative (asum) +import qualified Data.List as List +import qualified Data.List.Extra as List (stripInfix) +import Data.Maybe (fromMaybe) + +-- | This type controls whether an override is installed for a given name found in a module. +-- See 'Lang.Crucible.LLVM.Intrinsics.filterTemplates'. +data TemplateMatcher + = ExactMatch String + | PrefixMatch String + | SubstringsMatch [String] + | DarwinAliasMatch String + -- ^ Match a name up to some number of Darwin aliases. + -- See @Note [Darwin aliases]@. + +-- | Check whether a 'TemplateMatcher' matches a given function name. +matches :: + -- | Function name + String -> + TemplateMatcher -> + Bool +matches nm (ExactMatch x) = x == nm +matches nm (PrefixMatch pfx) = pfx `List.isPrefixOf` nm +matches nm (DarwinAliasMatch x) = x == stripDarwinAliases nm +matches nm (SubstringsMatch subs) = filterSubstrings subs nm + where + 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 [ List.stripPrefix sub tl | tl <- List.tails xs ] + + +-- | Remove all prefixes and suffixes that might occur in a Darwin alias for +-- a function name. See @Note [Darwin aliases]@. +stripDarwinAliases :: String -> String +stripDarwinAliases str = + -- Remove the \01_ prefix, if it exists... + let strNoPrefix = fromMaybe str (List.stripPrefix "\01_" str) in + -- ...and remove any suffixes as well. Because there can be multiple suffixes + -- in an alias, we use `stripInfix` in case one of the prefixes does not + -- appear at the very end of the name. + foldr (\suf s -> + case List.stripInfix suf s of + Just (before, after) -> before ++ after + Nothing -> s) + strNoPrefix + suffixes + where + suffixes :: [String] + suffixes = [ "$UNIX2003" + , "$INODE64" + , "$1050" + , "$NOCANCEL" + , "$DARWIN_EXTSN" + ] + +{- +Note [Darwin aliases] +~~~~~~~~~~~~~~~~~~~~~ +Operating systems derived from Darwin, such as macOS, define several aliases +for common libc functions for versioning purposes. These aliases are defined +using __asm, so when Clang compiles these aliases, the name that appears in the +resulting bitcode will look slightly different from what appears in the source +C file. For example, compiling the write() function with Clang on macOS will +produce LLVM bitcode with the name \01_write(), where \01 represents a leading +ASCII character with code 0x01. + +Aside from the \01_ prefix, there also a number of suffixes that can be used +in alias names (see `stripDarwinAliases` for the complete list). There are +enough possible combinations that it is not wise to try and write them all out +by hand. Instead, we take the approach that when using crucible-llvm on Darwin, +we treat any C function as possibly containing Darwin aliases. That is: + +* In `basic_llvm_override`, we use a special DarwinAliasMatch template matcher + on Darwin. When matching against possible overrides, DarwinAliasMatch + indicates that function should be match the underlying name after removing + any possible Darwin-related prefixes or suffixes (see the + `stripDarwinAliases` function, which implements this). +* If a function name in a program matches an override name after stripping + Darwin aliases, then we proceed to use the override, but with the override's + name switched out for the name of the function from the program. This way, + we write overrides for the "normalized" name (e.g., write) but have them work + seamlessly for aliases names (e.g., \01_write) as well. + +Currently, we only apply this special treatment in `basic_llvm_override`, as +we have only observed the aliases being used on libc functions. We may need to +apply this special case to other override functions (e.g., +`register_cpp_override`) if that proves insufficient. +-} + diff --git a/src/Lang/Crucible/LLVM/Intrinsics/Options.hs b/src/Lang/Crucible/LLVM/Intrinsics/Options.hs --- a/src/Lang/Crucible/LLVM/Intrinsics/Options.hs +++ b/src/Lang/Crucible/LLVM/Intrinsics/Options.hs @@ -20,9 +20,9 @@ -- ^ 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. + -- ^ The @__assert_fail()@ or @__assert_rtn()@ functions will cause Crucible + -- to fail, while other functions which trigger 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. diff --git a/src/Lang/Crucible/LLVM/MemModel.hs b/src/Lang/Crucible/LLVM/MemModel.hs --- a/src/Lang/Crucible/LLVM/MemModel.hs +++ b/src/Lang/Crucible/LLVM/MemModel.hs @@ -59,6 +59,7 @@ , G.ppPtr , G.ppTermExpr , llvmPointer_bv + , Partial.ptrToBv , Partial.projectLLVM_bv -- * Memory operations @@ -66,7 +67,6 @@ , doMallocUnbounded , G.AllocType(..) , G.Mutability(..) - , doMallocHandle , ME.FuncLookupError(..) , ME.ppFuncLookupError , doLookupHandle @@ -87,7 +87,6 @@ , loadMaybeString , strLen , uncheckedMemcpy - , bindLLVMFunPtr -- * \"Raw\" operations with LLVMVal , LLVMVal(..) @@ -96,6 +95,7 @@ , unpackMemValue , packMemValue , loadRaw + , loadArrayConcreteSizeRaw , storeRaw , condStoreRaw , storeConstRaw @@ -163,6 +163,7 @@ , G.pushStackFrameMem , G.popStackFrameMem , G.asMemAllocationArrayStore + , G.asMemMatchingArrayStore , SomeFnHandle(..) , G.SomeAlloc(..) , G.possibleAllocs @@ -214,6 +215,7 @@ import What4.Interface import What4.Expr( GroundValue ) +import qualified What4.Expr.ArrayUpdateMap as AUM import What4.InterpretedFloatingPoint import What4.ProgramLoc @@ -422,7 +424,7 @@ eval (LLVM_MemClear mvar (regValue -> ptr) bytes) = do mem <- getMem mvar - z <- liftIO $ bvLit sym knownNat (BV.zero knownNat) + z <- liftIO $ bvZero sym knownNat len <- liftIO $ bvLit sym PtrWidth (bytesToBV PtrWidth bytes) mem' <- liftIO $ doMemset bak PtrWidth mem ptr z len setMem mvar mem' @@ -562,7 +564,7 @@ let sym = backendGetSym bak blkNum <- liftIO $ nextBlock (memImplBlockSource mem) blk <- liftIO $ natLit sym blkNum - z <- liftIO $ bvLit sym PtrWidth (BV.zero PtrWidth) + z <- liftIO $ bvZero sym PtrWidth let heap' = G.allocMem G.StackAlloc blkNum (Just sz) alignment G.Mutable loc (memImplHeap mem) let ptr = LLVMPointer blk z @@ -624,22 +626,6 @@ 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. @@ -662,7 +648,7 @@ loc <- plSourceLoc <$> getCurrentProgramLoc sym let displayString = " " ++ show loc - z <- bvLit sym knownNat (BV.zero knownNat) + z <- bvZero sym knownNat (ptr, mem') <- doMalloc bak G.HeapAlloc G.Mutable displayString mem sz' alignment mem'' <- doMemset bak PtrWidth mem' ptr z sz' return (ptr, mem'') @@ -709,7 +695,7 @@ let sym = backendGetSym bak blkNum <- nextBlock (memImplBlockSource mem) blk <- natLit sym blkNum - z <- bvLit sym PtrWidth (BV.zero PtrWidth) + z <- bvZero sym PtrWidth let heap' = G.allocMem allocType blkNum sz alignment mut loc (memImplHeap mem) let ptr = LLVMPointer blk z let mem' = mem{ memImplHeap = heap' } @@ -720,25 +706,12 @@ 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 - +-- | Associate a function handle with an existing allocation. +-- +-- This can overwrite existing allocation/handle associations, and is used to do +-- so when registering lazily-translated CFGs. +-- +-- See also "Lang.Crucible.LLVM.Functions". doInstallHandle :: (Typeable a, IsSymBackend sym bak) => bak @@ -757,25 +730,6 @@ , " " ++ 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) @@ -1069,9 +1023,9 @@ LLVMPtr sym wptr {- ^ base pointer -} -> SymBV sym wptr {- ^ offset -} -> IO (LLVMPtr sym wptr) -doPtrAddOffset bak m x@(LLVMPointer blk _) off = do +doPtrAddOffset bak m x off = do let sym = backendGetSym bak - isBV <- natEq sym blk =<< natLit sym 0 + isBV <- ptrIsBv sym x x' <- ptrAdd sym PtrWidth x off v <- case asConstantPred isBV of Just True -> return isBV @@ -1177,16 +1131,17 @@ 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... + bvZero sym 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 + let err = AssertFailureSimError "Found pointer instead of byte in string passed to `strlen`" "" + test <- bvIsNonzero sym =<< Partial.ptrToBv bak err v iteM bvIte sym test (do cond' <- andPred sym cond test - p' <- doPtrAddOffset bak mem p =<< bvLit sym PtrWidth (BV.one PtrWidth) + p' <- doPtrAddOffset bak mem p =<< bvOne sym 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"]) @@ -1217,12 +1172,13 @@ 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 + let err = AssertFailureSimError "Found pointer instead of byte when loading string" "" + x <- Partial.ptrToBv bak err 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) + p' <- doPtrAddOffset bak mem p =<< bvOne sym PtrWidth go (f . (c':)) p' (fmap (\n -> n - 1) maxChars) Nothing -> addFailedAssertion bak @@ -1287,6 +1243,40 @@ let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr G.readMem sym PtrWidth gsym ptr valType alignment (memImplHeap mem) +-- | Load an array with concrete size from memory. +loadArrayConcreteSizeRaw :: + forall sym wptr . + (IsSymInterface sym, HasPtrWidth wptr, Partial.HasLLVMAnn sym, ?memOpts :: MemOptions) => + sym -> + MemImpl sym -> + LLVMPtr sym wptr -> + Natural -> + Alignment -> + IO (Either (Pred sym) (Pred sym, SymArray sym (SingleCtx (BaseBVType wptr)) (BaseBVType 8))) +loadArrayConcreteSizeRaw sym mem ptr sz alignment + | sz == 0 = do + zero_bv <- bvZero sym knownNat + zero_arr <- constantArray sym (Ctx.singleton $ BaseBVRepr PtrWidth) zero_bv + return $ Right (truePred sym, zero_arr) + | otherwise = do + let gsym = unsymbol <$> isGlobalPointer (memImplSymbolMap mem) ptr + res <- G.readMem sym PtrWidth gsym ptr (arrayType sz $ bitvectorType 1) alignment (memImplHeap mem) + case res of + Partial.NoErr ok llvm_val_arr -> do + case llvm_val_arr of + LLVMValArray _ llvm_vals -> do + let aum = AUM.fromAscList knownRepr $ V.toList $ V.imap + (\i -> \case + LLVMValInt _ byte | Just Refl <- testEquality (knownNat @8) (bvWidth byte) -> + (Ctx.singleton $ BVIndexLit PtrWidth $ BV.mkBV PtrWidth $ fromIntegral i, byte) + _ -> panic "MemModel.loadArrayRaw" ["expected LLVMValInt"]) + llvm_vals + zero_bv <- bvZero sym knownNat + arr <- arrayFromMap sym (Ctx.singleton $ BaseBVRepr PtrWidth) aum zero_bv + return $ Right (ok, arr) + _ -> panic "MemModel.loadArrayRaw" ["expected LLVMValArray"] + Partial.Err err -> return $ Left err + -- | Store an LLVM value in memory. Asserts that the pointer is valid and points -- to a mutable memory region. storeRaw :: @@ -1662,13 +1652,13 @@ 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 + 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 + diffBlk <- notPred sym =<< ptrSameAlloc sym dest src destfirst <- bvSle sym dend soff srcfirst <- bvSle sym send doff @@ -1688,15 +1678,15 @@ 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 + 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 + zero_bv <- bvZero sym PtrWidth - diffBlk <- notPred sym =<< natEq sym dblk sblk + diffBlk <- notPred sym =<< ptrSameAlloc sym dest src allPos <- andAllOf sym folded =<< mapM (bvSle sym zero_bv) [doff, dend, soff, send] destfirst <- bvSle sym zero_bv =<< bvSub sym soff dend diff --git a/src/Lang/Crucible/LLVM/MemModel/Generic.hs b/src/Lang/Crucible/LLVM/MemModel/Generic.hs --- a/src/Lang/Crucible/LLVM/MemModel/Generic.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Generic.hs @@ -58,6 +58,7 @@ , branchAbortMem , mergeMem , asMemAllocationArrayStore + , asMemMatchingArrayStore , isAligned , SomeAlloc(..) @@ -78,6 +79,7 @@ import Control.Lens import Control.Monad import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe import Data.IORef import Data.Maybe import qualified Data.List as List @@ -90,6 +92,7 @@ import Prettyprinter import Lang.Crucible.Panic (panic) +import Data.BitVector.Sized (BV) import qualified Data.BitVector.Sized as BV import Data.Parameterized.Classes import qualified Data.Parameterized.Context as Ctx @@ -790,7 +793,9 @@ 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 + b <- if noSatisfyingWriteFreshConstant ?memOpts + then freshConstant sym (safeSymbol "noSatisfyingWrite") BaseBoolRepr + else return $ falsePred sym Partial.Err <$> Partial.annotateME sym mop (NoSatisfyingWrite tp) b @@ -1037,13 +1042,13 @@ case sz of Nothing -> -- Unbounded access of an unbounded allocation must start at offset 0. - bvEq sym off =<< bvLit sym w (BV.zero w) + bvEq sym off =<< bvZero sym 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) + do zeroSize <- bvEq sym currSize =<< bvZero sym w noWrap <- bvUle sym off =<< bvNeg sym currSize orPred sym zeroSize noWrap @@ -1145,7 +1150,7 @@ , 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) + bvEq sym lowbits =<< bvZero sym bits isAligned sym _ _ _ = return (falsePred sym) @@ -1314,7 +1319,7 @@ arrayUpdate sym acc_arr (Ctx.singleton idx) byte Partial.NoErr _ (LLVMValZero _) -> do - byte <- bvLit sym knownRepr (BV.zero knownRepr) + byte <- bvZero sym knownRepr idx <- bvAdd sym (llvmPointerOffset ptr) =<< bvLit sym w (bytesToBV w off) arrayUpdate sym acc_arr (Ctx.singleton idx) byte @@ -1449,7 +1454,7 @@ _ -> return default_m - return (m', p1, p2) + return (memInsertArrayBlock (llvmPointerBlock ptr) m', p1, p2) -- | Write an array to memory. -- @@ -1521,7 +1526,7 @@ 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) + off <- bvZero sym w let p = LLVMPointer base off return (m & allocMem a b (Just sz) alignment mut loc & memAddWrite p (MemStore v tp alignment)) @@ -1570,7 +1575,7 @@ 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) + do p1 <- bvEq sym off =<< bvZero sym w (wasAllocated, notFreed) <- isAllocatedGeneric sym isHeapMutable blk (memAllocs m) return (memAddAlloc (freeMemAllocs blk loc) m, p1, wasAllocated, notFreed) where @@ -1629,6 +1634,22 @@ Just (AllocInfo atp sz mut alignment loc) -> [SomeAlloc atp n sz mut alignment loc] +-- | 'IO' plus memoization. The 'IORef' stores suspended computations with +-- 'Left' and evaluated results with 'Right'. +newtype MemoIO m a = MemoIO (IORef (Either (m a) a)) + +putMemoIO :: MonadIO m => m a -> m (MemoIO m a) +putMemoIO comp = MemoIO <$> liftIO (newIORef $ Left comp) + +getMemoIO :: MonadIO m => MemoIO m a -> m a +getMemoIO (MemoIO ref) = liftIO (readIORef ref) >>= \case + Left comp -> do + res <- comp + liftIO $ writeIORef ref $ Right res + return res + Right res -> return res + + -- | 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, @@ -1649,75 +1670,134 @@ 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) + , memMemberArrayBlock (llvmPointerBlock ptr) mem , [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 + do memo_nothing <- putMemoIO $ return Nothing + --putStrLn $ "asMemAllocationArrayStore: base=" ++ show blk_no ++ " sz=" ++ show (printSymExpr sz) + result <- findArrayStore sym w blk_no (BV.zero w) sz memo_nothing $ + 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))) +asMemMatchingArrayStore :: + (IsSymInterface sym, 1 <= w) => + sym -> + NatRepr w -> + LLVMPtr sym w -> + SymBV sym w -> + Mem sym -> + IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))) +asMemMatchingArrayStore sym w ptr sz mem + | Just blk_no <- asNat (llvmPointerBlock ptr) + , memMemberArrayBlock (llvmPointerBlock ptr) mem + , Just off <- asBV (llvmPointerOffset ptr) = do + --putStrLn $ "asMemMatchingArrayStore: ptr=" ++ show (blk_no, off) ++ " sz=" ++ show (printSymExpr sz) + memo_nothing <- putMemoIO $ return Nothing + findArrayStore sym w blk_no off sz memo_nothing $ memWritesAtConstant blk_no $ memWrites mem + | otherwise = return Nothing - findArrayStore _ _ [] = return Nothing +findArrayStore :: + (IsSymInterface sym, 1 <= w) => + sym -> + NatRepr w -> + Natural -> + BV w -> + SymBV sym w -> + MemoIO IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))) -> + [MemWrite sym] -> + IO (Maybe (Pred sym, SymArray sym (SingleCtx (BaseBVType w)) (BaseBVType 8))) +findArrayStore sym w blk_no off sz memo_cont = \case + [] -> getMemoIO memo_cont + head_mem_write : tail_mem_writes -> do + --putStrLn $ " findArrayStore: ptr=" ++ show (blk_no, off) ++ " sz=" ++ show (printSymExpr sz) + --putStrLn $ " findArrayStore: write=" ++ (case head_mem_write of MemWrite{} -> "write"; WriteMerge{} -> "merge") - 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)) + case head_mem_write of + MemWrite write_ptr write_source + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no == write_blk_no + , Just Refl <- testEquality w (ptrWidth write_ptr) + , Just write_off <- asBV (llvmPointerOffset write_ptr) + , off == write_off + , MemArrayStore arr (Just arr_store_sz) <- write_source -> 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 + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no == write_blk_no + , Just Refl <- testEquality w (ptrWidth write_ptr) + , Just write_off <- asBV (llvmPointerOffset write_ptr) + , Just sz_bv <- asBV sz + , MemCopy src_ptr mem_copy_sz <- write_source + , Just mem_copy_sz_bv <- asBV mem_copy_sz + , BV.ule write_off off + , BV.ule (BV.add w off sz_bv) (BV.add w write_off mem_copy_sz_bv) + , Just src_blk_no <- asNat (llvmPointerBlock src_ptr) + , Just src_off <- asBV (llvmPointerOffset src_ptr) -> + findArrayStore sym w src_blk_no (BV.add w src_off $ BV.sub w off write_off) sz memo_cont tail_mem_writes - | otherwise -> return Nothing + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no == write_blk_no + , Just Refl <- testEquality w (ptrWidth write_ptr) + , Just write_off <- asBV (llvmPointerOffset write_ptr) + , Just sz_bv <- asBV sz + , MemSet val mem_set_sz <- write_source + , Just mem_set_sz_bv <- asBV mem_set_sz + , BV.ule write_off off + , BV.ule (BV.add w off sz_bv) (BV.add w write_off mem_set_sz_bv) -> do + arr <- constantArray sym (Ctx.singleton $ BaseBVRepr w) val + return $ Just (truePred sym, arr) - 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) + | Just write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no == write_blk_no + , Just Refl <- testEquality w (ptrWidth write_ptr) + , Just write_off <- asBV (llvmPointerOffset write_ptr) -> do + maybe_write_sz <- runMaybeT $ writeSourceSize sym w write_source + case maybe_write_sz of + Just write_sz + | Just sz_bv <- asBV sz + , Just write_sz_bv <- asBV write_sz + , end <- BV.add w off sz_bv + , write_end <- BV.add w write_off write_sz_bv + , BV.ule end write_off || BV.ule write_end off -> + findArrayStore sym w blk_no off sz memo_cont tail_mem_writes + _ -> return Nothing - -- 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 write_blk_no <- asNat (llvmPointerBlock write_ptr) + , blk_no /= write_blk_no -> + findArrayStore sym w blk_no off sz memo_cont tail_mem_writes - (Just _, Nothing) -> - do rhs' <- findArrayStore blk_no sz tail_mem_writes - combineResults cond lhs_result rhs' + | otherwise -> return Nothing - (Nothing, Just _) -> - do lhs' <- findArrayStore blk_no sz tail_mem_writes - combineResults cond lhs' rhs_result + WriteMerge cond lhs_mem_writes rhs_mem_writes -> do + -- Only traverse the tail if necessary, and be careful + -- only to traverse it once + memo_tail <- putMemoIO $ findArrayStore sym w blk_no off sz memo_cont tail_mem_writes - (Nothing, Nothing) -> findArrayStore blk_no sz tail_mem_writes + lhs_result <- findArrayStore sym w blk_no off sz memo_tail (memWritesAtConstant blk_no lhs_mem_writes) + rhs_result <- findArrayStore sym w blk_no off sz memo_tail (memWritesAtConstant blk_no rhs_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)) + case (lhs_result, rhs_result) of + (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)) + (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)) + (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 + (Nothing, Nothing) -> pure Nothing + {- Note [Memory Model Design] diff --git a/src/Lang/Crucible/LLVM/MemModel/MemLog.hs b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs --- a/src/Lang/Crucible/LLVM/MemModel/MemLog.hs +++ b/src/Lang/Crucible/LLVM/MemModel/MemLog.hs @@ -56,6 +56,8 @@ , emptyChanges , emptyMem , memEndian + , memInsertArrayBlock + , memMemberArrayBlock -- * Pretty printing , ppType @@ -68,6 +70,7 @@ -- * Write ranges , writeRangesMem + , writeSourceSize -- * Concretization , concPtr @@ -86,6 +89,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import Numeric.Natural import Prettyprinter @@ -247,12 +252,7 @@ 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) + (, truePred sym) <$> inAlloc ba Just False -> k Nothing -> do (fallback', fallbackFreed') <- k @@ -325,7 +325,7 @@ -- 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 } +data Mem sym = Mem { memEndianForm :: EndianForm, _memState :: MemState sym, memArrayBlocks :: Set Natural } memState :: Lens' (Mem sym) (MemState sym) memState = lens _memState (\s v -> s { _memState = v }) @@ -416,12 +416,22 @@ emptyChanges = (mempty, mempty) emptyMem :: EndianForm -> Mem sym -emptyMem e = Mem { memEndianForm = e, _memState = EmptyMem 0 0 emptyChanges } +emptyMem e = Mem { memEndianForm = e, _memState = EmptyMem 0 0 emptyChanges, memArrayBlocks = Set.empty } memEndian :: Mem sym -> EndianForm memEndian = memEndianForm +memInsertArrayBlock :: IsExprBuilder sym => SymNat sym -> Mem sym -> Mem sym +memInsertArrayBlock blk mem = case asNat blk of + Just blk_no -> mem { memArrayBlocks = Set.insert blk_no (memArrayBlocks mem) } + Nothing -> mem { memArrayBlocks = Set.empty } +memMemberArrayBlock :: IsExprBuilder sym => SymNat sym -> Mem sym -> Bool +memMemberArrayBlock blk mem = case asNat blk of + Just blk_no -> Set.member blk_no (memArrayBlocks mem) + Nothing -> False + + -------------------------------------------------------------------------------- -- Pretty printing @@ -526,16 +536,19 @@ multiUnion :: (Ord k, Semigroup a) => Map k a -> Map k a -> Map k a multiUnion = Map.unionWith (<>) +-- | This will return 'Just' if the size of the write is bounded and 'Nothing' +-- is the size of the write is unbounded. writeSourceSize :: - (IsExprBuilder sym, HasPtrWidth w) => + (IsExprBuilder sym, 1 <= w) => sym -> + NatRepr w -> WriteSource sym w -> MaybeT IO (SymBV sym w) -writeSourceSize sym = \case +writeSourceSize sym w = \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 + liftIO $ bvLit sym w $ BV.mkBV w $ toInteger $ typeEnd 0 st MemArrayStore _arr Nothing -> MaybeT $ pure Nothing MemArrayStore _arr (Just sz) -> pure sz MemInvalidate _nm sz -> pure sz @@ -550,7 +563,7 @@ | Just Refl <- testEquality ?ptrWidth (ptrWidth ptr) -> case asNat (llvmPointerBlock ptr) of Just blk -> do - sz <- writeSourceSize sym wsrc + sz <- writeSourceSize sym ?ptrWidth wsrc pure $ Map.singleton blk [(llvmPointerOffset ptr, sz)] Nothing -> MaybeT $ pure Nothing | otherwise -> fail "foo" @@ -742,5 +755,6 @@ 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 +concMem sym conc mem = do + conc_st <- concMemState sym conc $ mem ^. memState + return $ mem & memState .~ conc_st diff --git a/src/Lang/Crucible/LLVM/MemModel/Options.hs b/src/Lang/Crucible/LLVM/MemModel/Options.hs --- a/src/Lang/Crucible/LLVM/MemModel/Options.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Options.hs @@ -67,6 +67,13 @@ -- semantics. -- -- If 'laxLoadsAndStores' is disabled, this option has no effect. + + , noSatisfyingWriteFreshConstant :: !Bool + -- ^ If 'True', for the 'NoSatisfyingWrite' annotation, make a fresh + -- constant as a proof obligation, which ensures it always fails. But, + -- because it's a variable, it won't be constant-folded away and it's + -- relatively sure the annotation will survive. If 'False', annotate + -- 'false'. } @@ -115,6 +122,7 @@ -- The choice of StableSymbolic here doesn't matter too much, since it -- won't have any effect when laxLoadsAndStores is disabled. , indeterminateLoadBehavior = StableSymbolic + , noSatisfyingWriteFreshConstant = True } diff --git a/src/Lang/Crucible/LLVM/MemModel/Partial.hs b/src/Lang/Crucible/LLVM/MemModel/Partial.hs --- a/src/Lang/Crucible/LLVM/MemModel/Partial.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Partial.hs @@ -46,6 +46,7 @@ , BoolAnn(..) , annotateME , annotateUB + , ptrToBv , projectLLVM_bv , floatToBV @@ -91,7 +92,7 @@ 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.Pointer ( pattern LLVMPointer, LLVMPtr, ptrIsBv ) 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(..)) @@ -262,15 +263,31 @@ (BBMemoryError (MemoryError mop rsn)) return p' +-- | Assert that the given LLVM pointer value is actually a raw bitvector and +-- extract its value. +ptrToBv :: + IsSymBackend sym bak => + bak -> + -- | Error to report if casting the pointer to a bitvector fails + SimErrorReason -> + LLVMPtr sym w -> + IO (SymBV sym w) +ptrToBv bak err p@(LLVMPointer _blk bv) = + do let sym = backendGetSym bak + isBv <- ptrIsBv sym p + assert bak isBv err + return bv + -- | Assert that the given LLVM pointer value is actually a raw bitvector and extract its value. +-- +-- Note that this assertion has a very generic message, which can be unhelpful +-- to users when it fails. Consider using 'ptrToBv' instead. 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 +projectLLVM_bv bak ptr = + let err = AssertFailureSimError "Pointer value coerced to bitvector" "" in + ptrToBv bak err ptr ------------------------------------------------------------------------ -- ** PartLLVMVal @@ -366,7 +383,7 @@ floatToBV sym _ (NoErr p (LLVMValZero (StorageType Float _))) = do nz <- W4I.natLit sym 0 - iz <- W4I.bvLit sym (knownNat @32) (BV.zero knownNat) + iz <- W4I.bvZero sym (knownNat @32) return (NoErr p (LLVMValInt nz iz)) floatToBV sym _ (NoErr p (LLVMValFloat Value.SingleSize v)) = @@ -392,7 +409,7 @@ doubleToBV sym _ (NoErr p (LLVMValZero (StorageType Double _))) = do nz <- W4I.natLit sym 0 - iz <- W4I.bvLit sym (knownNat @64) (BV.zero knownNat) + iz <- W4I.bvZero sym (knownNat @64) return (NoErr p (LLVMValInt nz iz)) doubleToBV sym _ (NoErr p (LLVMValFloat Value.DoubleSize v)) = @@ -924,7 +941,7 @@ LLVMValInt base off -> do zbase <- W4I.natLit sym 0 - zoff <- W4I.bvLit sym (W4I.bvWidth off) (BV.zero (W4I.bvWidth off)) + zoff <- W4I.bvZero sym (W4I.bvWidth off) base' <- W4I.natIte sym cond zbase base off' <- W4I.bvIte sym cond zoff off return $ LLVMValInt base' off' diff --git a/src/Lang/Crucible/LLVM/MemModel/Pointer.hs b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs --- a/src/Lang/Crucible/LLVM/MemModel/Pointer.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Pointer.hs @@ -20,6 +20,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -51,17 +52,26 @@ , mkNullPointer -- * Concretization + , ConcLLVMPtr(..) + , concLLVMPtr + , concLLVMPtrToSymbolic , concBV , concPtr , concPtr' + , concPtrFn + , concPtrFnMap + , concToSymPtrFn + , concToSymPtrFnMap -- * Operations on valid pointers , constOffset + , ptrSameAlloc , ptrEq , ptrLe , ptrAdd , ptrDiff , ptrSub + , ptrIsBv , ptrIsNull , isGlobalPointer , isGlobalPointer' @@ -74,7 +84,7 @@ , annotatePointerOffset ) where -import Control.Monad (guard) +import Control.Monad ((<=<), guard) import Data.Map (Map) import qualified Data.Map as Map (lookup) import Numeric.Natural @@ -86,14 +96,18 @@ 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.NatRepr import qualified Text.LLVM.AST as L +import qualified What4.Expr.GroundEval as W4GE import What4.Interface import What4.InterpretedFloatingPoint import What4.Expr (GroundValue) import Lang.Crucible.Backend +import qualified Lang.Crucible.Concretize as Conc +import Lang.Crucible.Panic (panic) import Lang.Crucible.Simulator.RegMap import Lang.Crucible.Simulator.Intrinsics import Lang.Crucible.Types @@ -109,9 +123,15 @@ deriving instance (Show (SymNat sym), Show (SymBV sym w)) => Show (LLVMPointer sym w) +-- | Retrieve this pointer\'s block number. +-- +-- Use of this function is discouraged, as it is abstraction-breaking. llvmPointerBlock :: LLVMPtr sym w -> SymNat sym llvmPointerBlock (LLVMPointer blk _) = blk +-- | Retrieve this pointer\'s offset. +-- +-- Use of this function is discouraged, as it is abstraction-breaking. llvmPointerOffset :: LLVMPtr sym w -> SymBV sym w llvmPointerOffset (LLVMPointer _ off) = off @@ -152,9 +172,42 @@ -- | 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) +mkNullPointer sym w = llvmPointer_bv sym =<< bvZero sym w +-- | A concrete LLVM pointer +data ConcLLVMPtr w + = ConcLLVMPtr + { -- | Concrete block number + concBlock :: Integer + -- | Concrete offset + , concOffset :: BV.BV w + , concWidth :: NatRepr w + } +-- | Concretize a symbolic pointer to a particular 'ConcLLVMPtr' that is +-- feasible in a model. +concLLVMPtr :: + IsExprBuilder sym => + -- | Model from SMT solver + (forall tp. SymExpr sym tp -> IO (GroundValue tp)) -> + RegValue sym (LLVMPointerType w) -> + IO (ConcLLVMPtr w) +concLLVMPtr conc (LLVMPointer blk off) = + do concBlk <- conc (natToIntegerPure blk) + concOff <- conc off + pure (ConcLLVMPtr concBlk concOff (bvWidth off)) + +-- | Create a symbolic pointer from a concrete one +concLLVMPtrToSymbolic :: + (IsExprBuilder sym, 1 <= w) => + sym -> + ConcLLVMPtr w -> + IO (RegValue sym (LLVMPointerType w)) +concLLVMPtrToSymbolic sym (ConcLLVMPtr concBlk concOff w) = do + symBlk <- integerToNat sym =<< intLit sym concBlk + symOff <- bvLit sym w concOff + pure (LLVMPointer symBlk symOff) + concBV :: (IsExprBuilder sym, 1 <= w) => sym -> @@ -170,10 +223,7 @@ (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 sym conc = concLLVMPtrToSymbolic sym <=< concLLVMPtr conc concPtr' :: (IsExprBuilder sym, 1 <= w) => @@ -183,7 +233,47 @@ IO (RegValue' sym (LLVMPointerType w)) concPtr' sym conc (RV ptr) = RV <$> concPtr sym conc ptr +type instance Conc.ConcIntrinsic "LLVM_pointer" (EmptyCtx ::> BVType w) = ConcLLVMPtr w +-- | An 'Conc.IntrinsicConcFn' for LLVM pointers +concPtrFn :: Conc.IntrinsicConcFn t "LLVM_pointer" +concPtrFn = Conc.IntrinsicConcFn $ \ctx tyCtx ptr -> + case Ctx.viewAssign tyCtx of + Ctx.AssignExtend (Ctx.viewAssign -> Ctx.AssignEmpty) (BVRepr _) -> + let W4GE.GroundEvalFn ge = Conc.model ctx + in concLLVMPtr ge ptr + -- These are impossible by the definition of LLVMPointerImpl + Ctx.AssignEmpty -> + panic "LLVM.MemModel.Pointer.concPtrFn" + [ "Impossible: LLVMPointerType empty context" ] + Ctx.AssignExtend _ _ -> + panic "LLVM.MemModel.Pointer.concPtrFn" + [ "Impossible: LLVMPointerType ill-formed context" ] + +-- | A singleton map suitable for use in a 'Conc.ConcCtx' if LLVM pointers are +-- the only intrinsic type in use +concPtrFnMap :: MapF.MapF SymbolRepr (Conc.IntrinsicConcFn t) +concPtrFnMap = MapF.singleton (knownSymbol @"LLVM_pointer") concPtrFn + +-- | A 'Conc.IntrinsicConcToSymFn' for LLVM pointers +concToSymPtrFn :: Conc.IntrinsicConcToSymFn "LLVM_pointer" +concToSymPtrFn = Conc.IntrinsicConcToSymFn $ \sym tyCtx ptr -> + case Ctx.viewAssign tyCtx of + Ctx.AssignExtend (Ctx.viewAssign -> Ctx.AssignEmpty) (BVRepr _) -> + concLLVMPtrToSymbolic sym ptr + -- These are impossible by the definition of LLVMPointerImpl + Ctx.AssignEmpty -> + panic "LLVM.MemModel.Pointer.concToSymPtrFn" + [ "Impossible: LLVMPointerType empty context" ] + Ctx.AssignExtend _ _ -> + panic "LLVM.MemModel.Pointer.concToSymPtrFn" + [ "Impossible: LLVMPointerType ill-formed context" ] + +-- | A singleton map suitable for use in 'Crucible.Concretize.concToSym' if LLVM +-- pointers are the only intrinsic type in use +concToSymPtrFnMap :: MapF.MapF SymbolRepr Conc.IntrinsicConcToSymFn +concToSymPtrFnMap = MapF.singleton (knownSymbol @"LLVM_pointer") concToSymPtrFn + -- | Mux function specialized to LLVM pointer values. muxLLVMPtr :: (1 <= w) => @@ -217,6 +307,22 @@ 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 point to the same allocation (i.e., have the same +-- block number). +-- +-- Using this function is preferred to pattern matching on 'LLVMPointer' or +-- 'llvmPointerBlock', because it operates at a higher level of abstraction +-- (i.e., if the representation of pointers were changed, it could continue to +-- work as intended). +ptrSameAlloc :: + (1 <= w, IsSymInterface sym) => + sym -> + LLVMPtr sym w -> + LLVMPtr sym w -> + IO (Pred sym) +ptrSameAlloc sym (LLVMPointer base1 _off1) (LLVMPointer base2 _off2) = + natEq sym base1 base2 + -- | Test whether two pointers are equal. ptrEq :: (1 <= w, IsSymInterface sym) => sym @@ -285,6 +391,20 @@ ptrSub sym _w (LLVMPointer base off1) off2 = do diff <- bvSub sym off1 off2 return (LLVMPointer base diff) + +-- | Test if a pointer value is a bitvector (i.e., has a block number of 0) +-- +-- Using this function is preferred to pattern matching on 'LLVMPointer' or +-- 'llvmPointerBlock', because it operates at a higher level of abstraction +-- (i.e., if the representation of pointers were changed, it could continue to +-- work as intended). +ptrIsBv :: + IsSymInterface sym => + sym -> + LLVMPtr sym w -> + IO (Pred sym) +ptrIsBv sym (LLVMPointer blk _off) = + natEq sym blk =<< natLit sym 0 -- | Test if a pointer value is the null pointer. ptrIsNull :: (1 <= w, IsSymInterface sym) diff --git a/src/Lang/Crucible/LLVM/MemModel/Value.hs b/src/Lang/Crucible/LLVM/MemModel/Value.hs --- a/src/Lang/Crucible/LLVM/MemModel/Value.hs +++ b/src/Lang/Crucible/LLVM/MemModel/Value.hs @@ -170,7 +170,7 @@ | Some w <- mkNatRepr (bytesToBits bytes) , Just LeqProof <- isPosNat w = do blk <- natLit sym 0 - bv <- bvLit sym w (BV.zero w) + bv <- bvZero sym w k (Just (blk, bv)) zeroInt _ _ k = k @1 Nothing @@ -313,7 +313,7 @@ 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) + LLVMValInt <$> natLit sym 0 <*> bvZero sym repr NatCaseEQ -> panic "zeroExpandLLVMVal" ["Zero value inside Bytes"] NatCaseGT (LeqProof :: LeqProof (w + 1) 0) -> panic "zeroExpandLLVMVal" ["Impossible: (w + 1) d + [] -> panic + "formatOctal" + ["Octal-formatted number with no digits"] + let altdigits = if Set.member PrintfAlternateForm flags && leadingPrecDigit /= '0' then '0':precdigits else precdigits diff --git a/src/Lang/Crucible/LLVM/QQ.hs b/src/Lang/Crucible/LLVM/QQ.hs --- a/src/Lang/Crucible/LLVM/QQ.hs +++ b/src/Lang/Crucible/LLVM/QQ.hs @@ -42,6 +42,7 @@ 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@ + | QQVectorVar String QQType -- ^ This constructor represents a vector type with a metavariable for its size, e.g. @<#var x ty>@ | 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 @@ -104,12 +105,13 @@ parseSeqType :: Char -> Char -> - (Int32 -> QQType -> QQType) -> + AT.Parser seqSz -> + (seqSz -> QQType -> QQType) -> AT.Parser QQType -parseSeqType start end cnstr = +parseSeqType start end parseSz cnstr = do void $ AT.char start AT.skipSpace - n <- AT.decimal + n <- parseSz AT.skipSpace void $ AT.char 'x' AT.skipSpace @@ -118,6 +120,15 @@ void $ AT.char end return $! cnstr n tp +parseVectorType :: AT.Parser QQType +parseVectorType = parseSeqType '<' '>' AT.decimal QQVector + +parseVectorVar :: AT.Parser QQType +parseVectorVar = parseSeqType '<' '>' parseIntVar QQVectorVar + +parseArrayType :: AT.Parser QQType +parseArrayType = parseSeqType '[' ']' AT.decimal QQArray + parseCommaSeparatedTypes :: AT.Parser [QQType] parseCommaSeparatedTypes = AT.choice [ do AT.skipSpace @@ -173,8 +184,9 @@ parseType :: AT.Parser QQType parseType = do base <- AT.choice - [ parseSeqType '<' '>' QQVector - , parseSeqType '[' ']' QQArray + [ parseVectorType + , parseVectorVar + , parseArrayType , parseStructType , parsePackedStructType , QQVar <$> parseVar @@ -226,6 +238,7 @@ case tp of QQVar nm -> varE (mkName nm) QQIntVar nm -> [| L.PrimType (L.Integer (fromInteger (intValue $(varE (mkName nm)) ))) |] + QQVectorVar nm t -> [| L.Vector (fromInteger (intValue $(varE (mkName nm)))) $(liftQQType t) |] QQSizeT -> varE 'IC.llvmSizeT QQSSizeT -> varE 'IC.llvmSSizeT QQAlias nm -> [| L.Alias nm |] @@ -263,6 +276,7 @@ liftTypeRepr t = case t of QQVar nm -> varE (mkName (nm++"_repr")) QQIntVar nm -> [| BVRepr $(varE (mkName nm)) |] + QQVectorVar _ t' -> [| VectorRepr $(liftTypeRepr t') |] QQSizeT -> [| SizeT |] QQSSizeT -> [| SSizeT |] QQPrim pt -> liftPrim pt diff --git a/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs b/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs new file mode 100644 --- /dev/null +++ b/src/Lang/Crucible/LLVM/SimpleLoopFixpointCHC.hs @@ -0,0 +1,1421 @@ +------------------------------------------------------------------------ +-- | +-- Module : Lang.Crucible.LLVM.SimpleLoopFixpointCHC +-- Description : Execution feature to compute loop fixpoint in +-- conjunction with CHC +-- Copyright : (c) Galois, Inc 2021 +-- License : BSD3 +-- Stability : provisional +-- +-- This offers a similar API to what is offered in +-- "Lang.Crucible.LLVM.SimpleLoopFixpoint", but this generates proof obligations +-- involving a predicate function (named @inv@). The intent is that a user will +-- leverage Z3's constrained horn-clause (CHC) functionality to synthesize an +-- implementation of @inv@ and then substitute it back into the proof +-- obligations. +------------------------------------------------------------------------ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} + + +module Lang.Crucible.LLVM.SimpleLoopFixpointCHC + ( FixpointEntry(..) + , FixpointState(..) + , CallFrameContext(..) + , SomeCallFrameContext(..) + , ExecutionFeatureContext(..) + , simpleLoopFixpoint + ) where + +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Foldable +import qualified Data.IntMap as IntMap +import Data.IORef +import Data.Kind +import qualified Data.List as List +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import Data.Set (Set) +import GHC.TypeLits (KnownNat) +import Numeric.Natural (Natural) +import qualified System.IO + +import qualified Data.BitVector.Sized as BV +import Data.Parameterized.Classes +import qualified Data.Parameterized.Context as Ctx +import qualified Data.Parameterized.Map as MapF +import Data.Parameterized.Map (MapF) +import Data.Parameterized.NatRepr +import Data.Parameterized.Some +import Data.Parameterized.TraversableF +import Data.Parameterized.TraversableFC + +import qualified What4.Config as W4 +import qualified What4.Expr.Builder as W4 +import qualified What4.Interface as W4 +import qualified What4.Solver as W4 + +import qualified Lang.Crucible.Analysis.Fixpoint.Components as C +import qualified Lang.Crucible.Backend as C +import qualified Lang.Crucible.CFG.Core as C +import qualified Lang.Crucible.FunctionHandle as C +import qualified Lang.Crucible.Panic as C +import qualified Lang.Crucible.Simulator.CallFrame as C +import qualified Lang.Crucible.Simulator.EvalStmt as C +import qualified Lang.Crucible.Simulator.ExecutionTree as C +import qualified Lang.Crucible.Simulator.GlobalState as C +import qualified Lang.Crucible.Simulator.Operations as C +import qualified Lang.Crucible.Simulator.RegMap as C +import qualified Lang.Crucible.Simulator as C + +import qualified Lang.Crucible.LLVM.Bytes as C +import qualified Lang.Crucible.LLVM.DataLayout as C +import qualified Lang.Crucible.LLVM.MemModel as C +import qualified Lang.Crucible.LLVM.MemModel.MemLog as C hiding (Mem) +import qualified Lang.Crucible.LLVM.MemModel.Pointer as C +import qualified Lang.Crucible.LLVM.MemModel.Type as C +-- import qualified Lang.Crucible.LLVM.MemModel.Generic as C (writeArrayMem) + + +-- | When live loop-carried dependencies are discovered as we traverse +-- a loop body, new "widening" variables are introduced to stand in +-- for those locations. When we introduce such a variable, we +-- capture what value the variable had when we entered the loop (the +-- \"header\" value); this is essentially the initial value of the +-- variable. We also compute what value the variable should take on +-- its next iteration assuming the loop doesn't exit and executes +-- along its backedge. This \"body\" value will be computed in +-- terms of the the set of all discovered live variables so far. +-- We know we have reached fixpoint when we don't need to introduce +-- and more fresh widening variables, and the body values for each +-- variable are stable across iterations. +data FixpointEntry sym tp = FixpointEntry + { headerValue :: W4.SymExpr sym tp + , bodyValue :: W4.SymExpr sym tp + } + +instance OrdF (W4.SymExpr sym) => OrdF (FixpointEntry sym) where + compareF x y = joinOrderingF + (compareF (headerValue x) (headerValue y)) + (compareF (bodyValue x) (bodyValue y)) +instance OrdF (FixpointEntry sym) => W4.TestEquality (FixpointEntry sym) where + testEquality x y = orderingF_refl $ compareF x y + +data MemLocation sym w = MemLocation + { memLocationBlock :: Natural + , memLocationOffset :: W4.SymBV sym w + , memLocationSize :: W4.SymBV sym w + } + +instance OrdF (W4.SymExpr sym) => Ord (MemLocation sym w) where + compare x y = + compare (memLocationBlock x) (memLocationBlock y) + <> toOrdering (compareF (memLocationOffset x) (memLocationOffset y)) + <> toOrdering (compareF (memLocationSize x) (memLocationSize y)) +instance OrdF (W4.SymExpr sym) => Eq (MemLocation sym w) where + x == y = EQ == compare x y + +data MemFixpointEntry sym wptr where + MemStoreFixpointEntry :: + (1 <= w) => + W4.SymBV sym w {- ^ bitvector join variable -} -> + C.StorageType -> + MemFixpointEntry sym wptr + MemArrayFixpointEntry :: + W4.SymArray sym (C.SingleCtx (W4.BaseBVType wptr)) (W4.BaseBVType 8) {- ^ array join variable -} -> + W4.SymBV sym wptr {- ^ length of the allocation -} -> + MemFixpointEntry sym wptr + + +-- | This datatype captures the state machine that progresses as we +-- attempt to compute a loop invariant for a simple structured loop. +data FixpointState sym wptr blocks args + -- | We have not yet encoundered the loop head + = BeforeFixpoint + + -- | We have encountered the loop head at least once, and are in the process + -- of converging to an inductive representation of the live variables + -- in the loop. + | ComputeFixpoint (FixpointRecord sym wptr blocks args) + + -- | We have found an inductively-strong representation of the live variables + -- of the loop, and have discovered the loop index structure controling the + -- execution of the loop. We are now executing the loop once more to compute + -- verification conditions for executions that reamain in the loop. + | CheckFixpoint + (FixpointRecord sym wptr blocks args) + (W4.SomeSymFn sym) -- ^ function that represents the loop invariant + (Some (Ctx.Assignment (W4.SymExpr sym))) -- ^ arguments to the loop invariant + (W4.Pred sym) -- ^ predicate that represents the loop condition + + -- | Finally, we stitch everything we have found together into the rest of the program. + -- Starting from the loop header one final time, we now force execution to exit the loop + -- and continue into the rest of the program. + | AfterFixpoint + (FixpointRecord sym wptr blocks args) + +-- | Data about the loop that we incrementally compute as we approach fixpoint. +data FixpointRecord sym wptr blocks args = FixpointRecord + { + -- | Block identifier of the head of the loop + fixpointBlockId :: C.BlockID blocks args + + -- | 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 (MemLocation sym wptr) (MemFixpointEntry sym wptr) + + , fixpointEqualitySubstitution :: MapF (W4.SymExpr sym) (W4.SymExpr sym) + + -- | The loop index variable + , fixpointIndex :: W4.SymBV sym wptr + } + + +data CallFrameContext sym wptr ext init ret blocks = CallFrameContext + { callFrameContextFixpointStates :: MapF (C.BlockID blocks) (FixpointState sym wptr blocks) + , callFrameContextLoopHeaders :: [C.Some (C.BlockID blocks)] + , callFrameContextCFG :: C.CFG ext blocks init ret + , callFrameContextParentLoop :: Map (C.Some (C.BlockID blocks)) (C.Some (C.BlockID blocks)) + , callFrameContextLoopHeaderBlockIds :: Set (C.Some (C.BlockID blocks)) + } + +data CallFrameHandle init ret blocks = CallFrameHandle (C.FnHandle init ret) (Ctx.Assignment (Ctx.Assignment C.TypeRepr) blocks) + deriving (Eq, Ord, Show) + +data SomeCallFrameContext sym wptr ext init ret = + forall blocks . SomeCallFrameContext (CallFrameContext sym wptr ext init ret blocks) + +unwrapSomeCallFrameContext :: + Ctx.Assignment (Ctx.Assignment C.TypeRepr) blocks -> + SomeCallFrameContext sym wptr ext init ret -> + CallFrameContext sym wptr ext init ret blocks +unwrapSomeCallFrameContext blocks_repr (SomeCallFrameContext ctx) = + case W4.testEquality blocks_repr (fmapFC C.blockInputs $ C.cfgBlockMap $ callFrameContextCFG ctx) of + Just Refl -> ctx + Nothing -> C.panic "SimpleLoopFixpoint.unwrapSomeCallFrameContext" ["type mismatch"] + +data ExecutionFeatureContext sym wptr ext = ExecutionFeatureContext + { executionFeatureContextFixpointStates :: C.FnHandleMap (SomeCallFrameContext sym wptr ext) + , executionFeatureContextInvPreds :: [W4.SomeSymFn sym] + , executionFeatureContextLoopFunEquivConds :: [W4.Pred sym] + } + +callFrameContextLookup :: + CallFrameHandle init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + CallFrameContext sym wptr ext init ret blocks +callFrameContextLookup (CallFrameHandle hdl blocks_repr) ctx = + unwrapSomeCallFrameContext blocks_repr $ + fromMaybe (C.panic "SimpleLoopFixpoint.callFrameContextLookup" ["missing call frame context", show hdl]) $ + C.lookupHandleMap hdl (executionFeatureContextFixpointStates ctx) + +callFrameContextUpdate :: + CallFrameHandle init ret blocks -> + (CallFrameContext sym wptr ext init ret blocks -> CallFrameContext sym wptr ext init ret blocks) -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +callFrameContextUpdate (CallFrameHandle hdl blocks_repr) f ctx = + ctx + { executionFeatureContextFixpointStates = C.updateHandleMap + (SomeCallFrameContext . f . unwrapSomeCallFrameContext blocks_repr) + hdl + (executionFeatureContextFixpointStates ctx) + } + +callFrameContextLookup' :: + CallFrameHandle init ret blocks -> + C.BlockID blocks args -> + ExecutionFeatureContext sym wptr ext -> + Maybe (FixpointState sym wptr blocks args) +callFrameContextLookup' hdl bid ctx = + MapF.lookup bid $ callFrameContextFixpointStates $ callFrameContextLookup hdl ctx + +callFrameContextInsert :: + CallFrameHandle init ret blocks -> + C.BlockID blocks args -> + FixpointState sym wptr blocks args -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +callFrameContextInsert hdl bid fs = + callFrameContextUpdate hdl $ + \ctx -> ctx { callFrameContextFixpointStates = MapF.insert bid fs (callFrameContextFixpointStates ctx) } + +callFrameContextPush :: + CallFrameHandle init ret blocks -> + C.Some (C.BlockID blocks) -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +callFrameContextPush hdl bid = + callFrameContextUpdate hdl $ + \ctx -> ctx { callFrameContextLoopHeaders = bid : callFrameContextLoopHeaders ctx } + +-- | Precondition: the context's 'callFrameContextLoopHeaders' should be +-- non-empty. +callFrameContextPop :: + CallFrameHandle init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +callFrameContextPop hdl = + callFrameContextUpdate hdl $ + \ctx -> ctx { callFrameContextLoopHeaders = + case callFrameContextLoopHeaders ctx of + _:hdrs -> hdrs + [] -> C.panic "callFrameContextPop" + ["Empty callFrameContextLoopHeaders"] } + +callFrameContextPeek :: + CallFrameHandle init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + Maybe (C.Some (C.BlockID blocks)) +callFrameContextPeek hdl ctx = + listToMaybe $ callFrameContextLoopHeaders $ callFrameContextLookup hdl ctx + +callFrameContextLoopHeaderBlockIds' :: + CallFrameHandle init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + Set (C.Some (C.BlockID blocks)) +callFrameContextLoopHeaderBlockIds' hdl = + callFrameContextLoopHeaderBlockIds . callFrameContextLookup hdl + +callFrameContextParentLoop' :: + CallFrameHandle init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + Map (C.Some (C.BlockID blocks)) (C.Some (C.BlockID blocks)) +callFrameContextParentLoop' hdl = + callFrameContextParentLoop . callFrameContextLookup hdl + +executionFeatureContextAddCallFrameContext :: + CallFrameHandle init ret blocks -> + CallFrameContext sym wptr ext init ret blocks -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +executionFeatureContextAddCallFrameContext (CallFrameHandle hdl _blocks_repr) ctx context = + context + { executionFeatureContextFixpointStates = + C.insertHandleMap hdl (SomeCallFrameContext ctx) (executionFeatureContextFixpointStates context) + } + +executionFeatureContextAddInvPred :: + W4.SomeSymFn sym -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +executionFeatureContextAddInvPred inv_pred context = + context { executionFeatureContextInvPreds = inv_pred : executionFeatureContextInvPreds context } + +executionFeatureContextAddLoopFunEquivCond :: + W4.Pred sym -> + ExecutionFeatureContext sym wptr ext -> + ExecutionFeatureContext sym wptr ext +executionFeatureContextAddLoopFunEquivCond cond context = + context { executionFeatureContextLoopFunEquivConds = cond : executionFeatureContextLoopFunEquivConds context } + + +newtype FixpointMonad sym a = + FixpointMonad (StateT (MapF (W4.SymExpr sym) (FixpointEntry sym)) IO a) + deriving (Functor, Applicative, Monad, MonadIO, MonadFail) + +deriving instance s ~ MapF (W4.SymExpr sym) (FixpointEntry sym) => MonadState s (FixpointMonad sym) + +runFixpointMonad :: + FixpointMonad sym a -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + IO (a, MapF (W4.SymExpr sym) (FixpointEntry sym)) +runFixpointMonad (FixpointMonad m) = runStateT m + + +joinRegEntries :: + (?logMessage :: String -> IO (), C.IsSymInterface sym) => + sym -> + Ctx.Assignment (C.RegEntry sym) ctx -> + Ctx.Assignment (C.RegEntry sym) ctx -> + FixpointMonad sym (Ctx.Assignment (C.RegEntry sym) ctx) +joinRegEntries 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_variable <- liftIO $ W4.freshConstant sym (W4.safeSymbol "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_variable join_entry subst + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) join_variable + | Just{} <- W4.asConcrete (C.llvmPointerOffset (C.regValue left)) -> do + return $ C.RegEntry (C.LLVMPointerRepr w) $ C.LLVMPointer (C.llvmPointerBlock (C.regValue left)) (C.llvmPointerOffset (C.regValue left)) + | 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 (W4.safeSymbol "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)] + + +joinMem :: + forall sym wptr . + (C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + C.MemImpl sym -> + C.MemWrites sym -> + IO (Map (MemLocation sym wptr) (MemFixpointEntry sym wptr)) +joinMem sym mem_impl mem_writes = do + ranges <- maybe (fail "SimpleLoopFixpoint: unsupported symbolic pointers") return =<< + runMaybeT (C.writeRangesMem @_ @wptr sym $ C.memImplHeap mem_impl) + + mem_subst <- case mem_writes of + C.MemWrites [C.MemWritesChunkIndexed indexed_writes] -> Map.fromList . catMaybes <$> mapM + (\case + C.MemWrite ptr mem_source + | Just Refl <- W4.testEquality ?ptrWidth (C.ptrWidth ptr) + , Just blk <- W4.asNat (C.llvmPointerBlock ptr) -> do + sz <- maybe (fail "SimpleLoopFixpoint: unsupported MemSource") return =<< + runMaybeT (C.writeSourceSize sym (C.ptrWidth ptr) mem_source) + let mem_loc = MemLocation + { memLocationBlock = blk + , memLocationOffset = C.llvmPointerOffset ptr + , memLocationSize = sz + } + + is_loop_local <- and <$> mapM + (\(prev_off, prev_sz) -> do + disjoint_pred <- C.buildDisjointRegionsAssertionWithSub + sym + ptr + sz + (C.LLVMPointer (C.llvmPointerBlock ptr) prev_off) + prev_sz + return $ W4.asConstantPred disjoint_pred == Just True) + (Map.findWithDefault [] blk ranges) + + if not is_loop_local then do + mem_entry <- case mem_source of + C.MemStore _ storage_type _ -> + case W4.mkNatRepr $ C.bytesToBits (C.typeEnd 0 storage_type) of + C.Some bv_width + | Just C.LeqProof <- W4.testLeq (W4.knownNat @1) bv_width -> do + join_variable <- W4.freshConstant sym (W4.safeSymbol "mem_join_var") (W4.BaseBVRepr bv_width) + return $ MemStoreFixpointEntry join_variable storage_type + | otherwise -> + C.panic + "SimpleLoopFixpoint.simpleLoopFixpoint" + ["unexpected storage type " ++ show storage_type] + + C.MemArrayStore arr _ -> do + join_variable <- W4.freshConstant sym (W4.safeSymbol "mem_join_var") (W4.exprType arr) + return $ MemArrayFixpointEntry join_variable sz + + _ -> fail "SimpleLoopFixpoint.joinMem: unsupported MemSource" + + return $ Just (mem_loc, mem_entry) + + else + return Nothing + + _ -> fail $ "SimpleLoopFixpoint: not MemWrite: " ++ show (C.ppMemWrites mem_writes)) + (List.concat $ IntMap.elems indexed_writes) + + C.MemWrites [] -> return Map.empty + + _ -> fail $ "SimpleLoopFixpoint: not MemWritesChunkIndexed: " ++ show (C.ppMemWrites mem_writes) + + checkDisjointRegions sym $ Map.keys mem_subst + + return mem_subst + +checkDisjointRegions :: + (C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + [MemLocation sym wptr] -> + IO () +checkDisjointRegions sym = \case + hd_mem_loc : tail_mem_locs -> do + mapM_ (checkDisjointRegions' sym hd_mem_loc) tail_mem_locs + checkDisjointRegions sym tail_mem_locs + [] -> return () + +checkDisjointRegions' :: + (C.IsSymInterface sym, C.HasPtrWidth wptr) => + sym -> + MemLocation sym wptr -> + MemLocation sym wptr -> + IO () +checkDisjointRegions' sym mem_loc1 mem_loc2 = do + ptr1 <- memLocationPtr sym mem_loc1 + ptr2 <- memLocationPtr sym mem_loc2 + disjoint_pred <- C.buildDisjointRegionsAssertionWithSub + sym + ptr1 + (memLocationSize mem_loc1) + ptr2 + (memLocationSize mem_loc2) + when (W4.asConstantPred disjoint_pred /= Just True) $ + fail $ + "SimpleLoopFixpoint: non-disjoint ranges: off1=" + ++ show (W4.printSymExpr $ C.llvmPointerOffset ptr1) + ++ ", sz1=" + ++ show (W4.printSymExpr $ memLocationSize mem_loc1) + ++ ", off2=" + ++ show (W4.printSymExpr $ C.llvmPointerOffset ptr2) + ++ ", sz2=" + ++ show (W4.printSymExpr $ memLocationSize mem_loc2) + + +loadMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + Map (MemLocation sym wptr) (MemFixpointEntry sym wptr) -> + IO (MapF (W4.SymExpr sym) (W4.SymExpr sym)) +loadMemJoinVariables bak mem subst = + let sym = C.backendGetSym bak in + MapF.fromList . catMaybes <$> mapM + (\(mem_loc, mem_entry) -> do + ptr <- memLocationPtr sym mem_loc + case mem_entry of + MemStoreFixpointEntry join_variable storage_type -> do + val <- C.doLoad bak mem ptr storage_type (C.LLVMPointerRepr $ W4.bvWidth join_variable) C.noAlignment + case W4.asNat (C.llvmPointerBlock val) of + Just 0 -> return $ Just $ MapF.Pair join_variable $ C.llvmPointerOffset val + _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" ++ show (C.ppPtr val) + -- foo <- C.loadRaw sym mem ptr storage_type C.noAlignment + -- case foo of + -- C.NoErr _p val' -> do + -- val <- C.unpackMemValue sym (C.LLVMPointerRepr $ W4.bvWidth join_variable) val' + -- case W4.asNat (C.llvmPointerBlock val) of + -- Just 0 -> return $ Just $ MapF.Pair join_variable $ C.llvmPointerOffset val + -- _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables: unexpected val:" ++ show (C.ppPtr val) + -- C.Err{} -> -- return Nothing + -- fail $ "SimpleLoopFixpoint.loadMemJoinVariables: loadRaw failed" + MemArrayFixpointEntry join_variable _size -> do + -- TODO: handle arrays + maybe_allocation_array <- C.asMemAllocationArrayStore sym ?ptrWidth ptr (C.memImplHeap mem) + case maybe_allocation_array of + Just (ok, arr, _arr_sz) | Just True <- W4.asConstantPred ok -> do + return $ Just $ MapF.Pair join_variable arr + _ -> fail $ "SimpleLoopFixpoint.loadMemJoinVariables") + (Map.toAscList subst) + +storeMemJoinVariables :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + bak -> + C.MemImpl sym -> + Map (MemLocation sym wptr) (MemFixpointEntry sym wptr) -> + MapF (W4.SymExpr sym) (W4.SymExpr sym) -> + IO (C.MemImpl sym) +storeMemJoinVariables bak mem mem_subst eq_subst = do + let sym = C.backendGetSym bak + foldlM + (\mem_acc (mem_loc, mem_entry) -> do + ptr <- memLocationPtr sym mem_loc + case mem_entry of + MemStoreFixpointEntry join_variable storage_type -> do + C.doStore bak mem_acc ptr (C.LLVMPointerRepr $ W4.bvWidth join_variable) storage_type C.noAlignment =<< + C.llvmPointer_bv sym (findWithDefaultKey eq_subst join_variable) + MemArrayFixpointEntry join_variable size -> do + C.doArrayStore bak mem_acc ptr C.noAlignment (findWithDefaultKey eq_subst join_variable) size) + -- (heap, p1, p2) <- C.writeArrayMem + -- sym + -- ?ptrWidth + -- ptr + -- C.noAlignment + -- (findWithDefaultKey eq_subst join_variable) + -- (Just size) + -- (C.memImplHeap mem_acc) + -- return $ mem_acc { C.memImplHeap = heap }) + mem + (Map.toAscList mem_subst) + +memLocationPtr :: + C.IsSymInterface sym => + sym -> + MemLocation sym wptr -> + IO (C.LLVMPtr sym wptr) +memLocationPtr sym (MemLocation { memLocationBlock = blk, memLocationOffset = off }) = + C.LLVMPointer <$> W4.natLit sym blk <*> return off + + +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 + +loopIndexLinearSubstitution :: + (C.IsSymInterface sym, C.HasPtrWidth wptr, MonadIO m) => + sym -> + W4.SymBV sym wptr -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + m (MapF (W4.SymExpr sym) (W4.SymExpr sym)) +loopIndexLinearSubstitution sym index_variable = + MapF.traverseMaybeWithKey + (\variable entry -> case W4.testEquality (W4.exprType variable) (W4.exprType index_variable) of + Just Refl -> do + diff <- liftIO $ W4.bvSub sym (bodyValue entry) variable + case W4.asBV diff of + Just{} -> liftIO $ Just <$> (W4.bvAdd sym (headerValue entry) =<< W4.bvMul sym index_variable diff) + Nothing -> return Nothing + Nothing -> return Nothing) + +-- find widening variables that are actually the same (up to syntactic equality) +-- and can be substituted for each other +uninterpretedConstantEqualitySubstitution :: + (C.IsSymInterface sym, sym ~ W4.ExprBuilder t st fs, MonadIO m, MonadFail m, ?logMessage :: String -> IO ()) => + sym -> + MapF (W4.SymExpr sym) (FixpointEntry sym) -> + m (MapF (W4.SymExpr sym) (FixpointEntry sym), MapF (W4.SymExpr sym) (W4.SymExpr sym)) +uninterpretedConstantEqualitySubstitution sym substitution = do + let reverse_substitution = MapF.foldlWithKey' + (\accumulator variable entry -> MapF.insert entry variable accumulator) + MapF.empty + substitution + let uninterpreted_constant_substitution = + MapF.filterWithKey (\variable entry -> isNothing $ W4.testEquality variable entry) $ + fmapF (\entry -> fromJust $ MapF.lookup entry reverse_substitution) + substitution + let normal_substitution = MapF.filterWithKey + (\variable _entry -> isNothing $ MapF.lookup variable uninterpreted_constant_substitution) + substitution + + liftIO $ ?logMessage "vars:" + mapM_ + (\(MapF.Pair variable entry) -> do + let body_vars = Set.map (C.mapSome $ W4.varExpr sym) $ W4.exprUninterpConstants sym $ bodyValue entry + liftIO $ ?logMessage $ show (W4.printSymExpr variable) ++ " :: "++ show (W4.exprType variable) ++ " -> " ++ (show $ Set.map (C.viewSome $ show . W4.printSymExpr) $ body_vars)) + (MapF.toList normal_substitution) + + foo <- MapF.fromList <$> filterM + (\(MapF.Pair variable entry) -> do + let body_vars = Set.map (C.mapSome $ W4.varExpr sym) $ W4.exprUninterpConstants sym $ bodyValue entry + if Set.notMember (C.Some variable) body_vars then do + let lalala = runIdentity $ MapF.fromKeysM (return . W4.varExpr sym) $ W4.exprUninterpConstants sym $ bodyValue entry + let foobar = fmapF headerValue $ MapF.mapMaybe (\v -> MapF.lookup v normal_substitution) lalala + bar <- liftIO $ W4.isEq sym (headerValue entry) =<< W4.substituteBoundVars sym foobar (bodyValue entry) + liftIO $ ?logMessage $ "la: " ++ (show $ W4.printSymExpr variable) + liftIO $ ?logMessage $ "headerValue entry: " ++ (show $ W4.printSymExpr $ headerValue entry) + liftIO $ ?logMessage $ "bodyValue entry:" ++ (show $ W4.printSymExpr $ bodyValue entry) + liftIO $ ?logMessage $ "bar: " ++ (show $ W4.printSymExpr $ bar) + if Just True == W4.asConstantPred bar then do + liftIO $ ?logMessage "lala" + return True + else do + notbar <- liftIO $ W4.notPred sym bar + lala <- liftIO $ W4.runZ3InOverride sym (W4.defaultLogData { W4.logVerbosity = 2 }) [notbar] $ return . W4.isUnsat + when lala $ do + liftIO $ ?logMessage "lalala" + return lala + else + return False) + (MapF.toList normal_substitution) + + unless (Set.disjoint (Set.fromList $ MapF.keys foo) (foldMapF (Set.map (C.mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym) $ fmapF bodyValue foo)) $ + fail "SimpleLoopFixpoint: uninterpretedConstantEqualitySubstitution: not disjoint" + + return + ( MapF.mergeWithKey (\_ _ _ -> Nothing) id (const MapF.empty) normal_substitution foo -- difference + , MapF.mergeWithKey (\_ _ -> Just) id id uninterpreted_constant_substitution $ fmapF bodyValue foo -- union + ) + + +-- -- | Given the WTO analysis results, find the nth loop. +-- -- Return the identifier of the loop header, and a list of all the blocks +-- -- that are part of the loop body. It is at this point that we check +-- -- that the loop has the necessary properties; there must be a single +-- -- entry point to the loop, and it must have a single back-edge. Otherwise, +-- -- the analysis will not work correctly. +-- computeLoopBlocks :: forall ext blocks init ret k . +-- (k ~ C.Some (C.BlockID blocks)) => +-- C.CFG ext blocks init ret -> +-- Integer -> +-- IO (k, [k]) +-- computeLoopBlocks cfg loopNum = +-- case List.genericDrop loopNum (Map.toList loop_map) of +-- [] -> fail ("Did not find " ++ show loopNum ++ " loop headers") +-- (p:_) -> do checkSingleEntry p +-- checkSingleBackedge p +-- return p + +-- where +-- -- There should be exactly one block which is not part of the loop body that +-- -- can jump to @hd@. +-- checkSingleEntry :: (k,[k]) -> IO () +-- checkSingleEntry (hd, body) = +-- case filter (\x -> not (elem x body) && elem hd (C.cfgSuccessors cfg x)) allReachable of +-- [_] -> return () +-- _ -> fail "SimpleLoopInvariant feature requires a single-entry loop!" + +-- -- There should be exactly on block in the loop body which can jump to @hd@. +-- checkSingleBackedge :: (k,[k]) -> IO () +-- checkSingleBackedge (hd, body) = +-- case filter (\x -> elem hd (C.cfgSuccessors cfg x)) body of +-- [_] -> return () +-- _ -> fail "SimpleLoopInvariant feature requires a loop with a single backedge!" + +-- flattenWTOComponent = \case +-- C.SCC C.SCCData{..} -> wtoHead : concatMap flattenWTOComponent wtoComps +-- C.Vertex v -> [v] + +-- loop_map = Map.fromList $ mapMaybe +-- (\case +-- C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps) +-- C.Vertex{} -> Nothing) +-- wto + +-- allReachable = concatMap flattenWTOComponent wto + +-- wto = C.cfgWeakTopologicalOrdering cfg + + +-- | This execution feature is designed to allow a limited form of +-- verification for programs with unbounded looping structures. +-- +-- It is currently highly experimental and has many limitations. +-- Most notably, it only really works properly for functions +-- consisting of a single, non-nested loop with a single exit point. +-- Moreover, the loop must have an indexing variable that counts up +-- from a starting point by a fixed stride amount. +-- +-- Currently, these assumptions about the loop structure are not +-- checked. +-- +-- The basic use case here is for verifying functions that loop +-- through an array of data of symbolic length. This is done by +-- providing a \""fixpoint function\" which describes how the live +-- values in the loop at an arbitrary iteration are used to compute +-- the final values of those variables before execution leaves the +-- loop. The number and order of these variables depends on +-- internal details of the representation, so is relatively fragile. +simpleLoopFixpoint :: + (C.IsSymInterface sym, sym ~ W4.ExprBuilder t st fs, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions) => + sym -> + C.CFG ext blocks init ret {- ^ The function we want to verify -} -> + C.GlobalVar C.Mem {- ^ global variable representing memory -} -> + Maybe (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), Maybe (W4.Pred sym))) -> + IO (C.ExecutionFeature p sym ext rtp, IORef (ExecutionFeatureContext sym wptr ext)) +simpleLoopFixpoint sym _cfg mem_var maybe_fixpoint_func = do + verbSetting <- W4.getOptionSetting W4.verbosity $ W4.getConfiguration sym + _verb <- fromInteger @Natural <$> W4.getOpt verbSetting + + -- let loop_map = Map.fromList $ mapMaybe + -- (\case + -- scc@(C.SCC _) -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps) + -- C.Vertex{} -> Nothing) + -- (C.cfgWeakTopologicalOrdering cfg) + + -- Doesn't really work if there are nested loops: looop datastructures will + -- overwrite each other. Currently no error message. + + -- Really only works for single-exit loops; need a message for that too. + + -- let flattenWTOComponent = \case + -- C.SCC C.SCCData{..} -> wtoHead : concatMap flattenWTOComponent wtoComps + -- C.Vertex v -> [v] + -- let loop_map = Map.fromList $ mapMaybe + -- (\case + -- C.SCC C.SCCData{..} -> Just (wtoHead, wtoHead : concatMap flattenWTOComponent wtoComps) + -- C.Vertex{} -> Nothing) + -- (C.cfgWeakTopologicalOrdering cfg) + + + -- let parent_wto_component = C.parentWTOComponent $ C.cfgWeakTopologicalOrdering cfg + -- fixpoint_state_ref <- newIORef $ + -- FrameContext + -- { frameContextFixpointStates = MapF.empty + -- , frameContextLoopHeaders = [] + -- , frameContextCFG = cfg + -- , frameContextParentLoop = parent_wto_component + -- , frameContextLoopHeaderBlockIds = Set.fromList $ Map.elems parent_wto_component + -- } + + fixpoint_state_ref <- newIORef $ + ExecutionFeatureContext + { executionFeatureContextFixpointStates = C.emptyHandleMap + , executionFeatureContextInvPreds = [] + , executionFeatureContextLoopFunEquivConds = [] + } + + -- initializeCallFrameContext cfg fixpoint_state_ref + + return $ (, fixpoint_state_ref) $ C.ExecutionFeature $ \exec_state -> do + -- let ?logMessage = \msg -> when (_verb >= 3) $ do + let ?logMessage = \msg -> do + let h = C.printHandle $ C.execStateContext exec_state + System.IO.hPutStrLn h msg + System.IO.hFlush h + + -- cfg_handle <- C.cfgHandle . callFrameContextCFG <$> readIORef fixpoint_state_ref + -- cfg_block_map <- C.cfgBlockMap . callFrameContextCFG <$> readIORef fixpoint_state_ref + -- parent_loop_map <- callFrameContextParentLoop <$> readIORef fixpoint_state_ref + -- loop_header_block_ids <- callFrameContextLoopHeaderBlockIds <$> readIORef fixpoint_state_ref + -- maybe_some_loop_block_id <- callFrameContextPeek <$> readIORef fixpoint_state_ref + C.withBackend (C.execStateContext exec_state) $ \bak -> case exec_state of + C.RunningState (C.RunBlockStart block_id) sim_state + | SomeCallFrameHandle call_frame_handle <- callFrameHandle (sim_state ^. C.stateCrucibleFrame) -> do + loop_header_block_ids <- callFrameContextLoopHeaderBlockIds' call_frame_handle <$> readIORef fixpoint_state_ref + if Set.member (C.Some block_id) loop_header_block_ids then do + ?logMessage $ "!!!SimpleLoopFixpoint: RunningState: RunBlockStart: " ++ show block_id + advanceFixpointState bak mem_var maybe_fixpoint_func call_frame_handle block_id sim_state fixpoint_state_ref + else do + ?logMessage $ "SimpleLoopFixpoint: RunningState: RunBlockStart: " ++ show block_id + return C.ExecutionFeatureNoChange + + -- | C.SomeHandle cfg_handle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + -- -- make sure the types match + -- , Just Refl <- W4.testEquality + -- (fmapFC C.blockInputs cfg_block_map) + -- (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + -- -- loop map is what we computed above, is this state at a loop header + -- , Set.member (C.Some block_id) loop_header_block_ids -> + -- advanceFixpointState bak mem_var maybe_fixpoint_func cfg_handle block_id sim_state fixpoint_state_ref + + -- | otherwise -> do + -- ?logMessage $ "SimpleLoopFixpoint: RunningState: RunBlockStart: " ++ show block_id + -- return C.ExecutionFeatureNoChange + + -- TODO: maybe need to rework this, so that we are sure to capture even concrete exits from the loop. + C.SymbolicBranchState branch_condition true_frame false_frame _target sim_state + | JustPausedFrameTgtId true_frame_some_block_id <- pausedFrameTgtId true_frame + , JustPausedFrameTgtId false_frame_some_block_id <- pausedFrameTgtId false_frame + , SomeCallFrameHandle call_frame_handle <- callFrameHandle (sim_state ^. C.stateCrucibleFrame) -> do + maybe_some_loop_block_id <- callFrameContextPeek call_frame_handle <$> readIORef fixpoint_state_ref + parent_loop_map <- callFrameContextParentLoop' call_frame_handle <$> readIORef fixpoint_state_ref + -- , C.SomeHandle cfg_handle == C.frameHandle (sim_state ^. C.stateCrucibleFrame) + -- , Just Refl <- W4.testEquality + -- (fmapFC C.blockInputs cfg_block_map) + -- (fmapFC C.blockInputs $ C.frameBlockMap $ sim_state ^. C.stateCrucibleFrame) + -- , Just (Some loop_block_id) <- maybe_some_loop_block_id + -- , true_frame_parent_loop_id <- Map.lookup true_frame_some_block_id parent_loop_map + -- , false_frame_parent_loop_id <- Map.lookup false_frame_some_block_id parent_loop_map + -- , true_frame_parent_loop_id /= maybe_some_loop_block_id || false_frame_parent_loop_id /= maybe_some_loop_block_id -> do + if| Just (Some loop_block_id) <- maybe_some_loop_block_id + , true_frame_parent_loop_id <- if true_frame_some_block_id /= C.Some loop_block_id then Map.lookup true_frame_some_block_id parent_loop_map else maybe_some_loop_block_id + , false_frame_parent_loop_id <- if false_frame_some_block_id /= C.Some loop_block_id then Map.lookup false_frame_some_block_id parent_loop_map else maybe_some_loop_block_id + , true_frame_parent_loop_id /= maybe_some_loop_block_id || false_frame_parent_loop_id /= maybe_some_loop_block_id -> do + ?logMessage $ "!!!SimpleLoopFixpoint: SymbolicBranchState: " ++ show (true_frame_some_block_id, false_frame_some_block_id) + handleSymbolicBranch + bak + call_frame_handle + loop_block_id + branch_condition + true_frame + false_frame + true_frame_parent_loop_id + false_frame_parent_loop_id + sim_state + fixpoint_state_ref + | otherwise -> do + ?logMessage $ "SimpleLoopFixpoint: SymbolicBranchState: " ++ show (W4.printSymExpr branch_condition, true_frame_some_block_id, false_frame_some_block_id) + return C.ExecutionFeatureNoChange + + C.CallState _return_handler (C.CrucibleCall _block_id call_frame) _sim_state + | C.CallFrame { C._frameCFG = callee_cfg } <- call_frame -> do + initializeCallFrameContext callee_cfg fixpoint_state_ref + return C.ExecutionFeatureNoChange + C.TailCallState _value_from_value (C.CrucibleCall _block_id call_frame) _sim_state + | C.CallFrame { C._frameCFG = callee_cfg } <- call_frame -> do + initializeCallFrameContext callee_cfg fixpoint_state_ref + return C.ExecutionFeatureNoChange + + _ -> return C.ExecutionFeatureNoChange + + +initializeCallFrameContext :: + (?logMessage :: String -> IO ()) => + C.CFG ext blocks init ret -> + IORef (ExecutionFeatureContext sym wptr ext) -> + IO () +initializeCallFrameContext cfg context_ref = do + ?logMessage $ "SimpleLoopFixpoint: cfgHandle: " ++ show (C.cfgHandle cfg) + ?logMessage $ "SimpleLoopFixpoint: cfg: " ++ show (toListFC (\b -> (C.Some (C.blockID b), C.nextBlocks b)) $ C.cfgBlockMap cfg) + ?logMessage $ "SimpleLoopFixpoint: cfgWeakTopologicalOrdering: " ++ show (C.cfgWeakTopologicalOrdering cfg) + let parent_wto_component = C.parentWTOComponent $ C.cfgWeakTopologicalOrdering cfg + let call_frame_handle = CallFrameHandle (C.cfgHandle cfg) $ fmapFC C.blockInputs $ C.cfgBlockMap cfg + modifyIORef' context_ref $ executionFeatureContextAddCallFrameContext call_frame_handle $ + CallFrameContext + { callFrameContextFixpointStates = MapF.empty + , callFrameContextLoopHeaders = [] + , callFrameContextCFG = cfg + , callFrameContextParentLoop = parent_wto_component + , callFrameContextLoopHeaderBlockIds = Set.fromList $ Map.elems parent_wto_component + } + + +initializeFixpointState :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) => + bak -> + C.GlobalVar C.Mem -> + CallFrameHandle init ret blocks -> + C.BlockID blocks args -> + C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) -> + IORef (ExecutionFeatureContext sym wptr ext) -> + IO (C.ExecutionFeatureResult p sym ext rtp) +initializeFixpointState bak mem_var call_frame_handle block_id sim_state fixpoint_state_ref = do + let sym = C.backendGetSym bak + assumption_frame_identifier <- C.pushAssumptionFrame bak + ?logMessage $ "!!!SimpleLoopFixpoint: initializeFixpointState: block_id=" ++ show block_id ++ ", assumption_frame_identifier=" ++ show assumption_frame_identifier + index_var <- W4.freshConstant sym (W4.safeSymbol "index_var") W4.knownRepr + 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 } + modifyIORef' fixpoint_state_ref $ callFrameContextInsert call_frame_handle block_id $ ComputeFixpoint $ + FixpointRecord + { fixpointBlockId = block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = MapF.empty + , fixpointRegMap = sim_state ^. (C.stateCrucibleFrame . C.frameRegs) + , fixpointMemSubstitution = Map.empty + , fixpointEqualitySubstitution = MapF.empty + , fixpointIndex = index_var + } + modifyIORef' fixpoint_state_ref $ callFrameContextPush call_frame_handle $ Some block_id + return $ C.ExecutionFeatureModifiedState $ C.RunningState (C.RunBlockStart block_id) $ + sim_state & C.stateGlobals %~ C.insertGlobal mem_var res_mem_impl + +advanceFixpointState :: + (C.IsSymBackend sym bak, sym ~ W4.ExprBuilder t st fs, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) => + bak -> + C.GlobalVar C.Mem -> + Maybe (MapF (W4.SymExpr sym) (FixpointEntry sym) -> W4.Pred sym -> IO (MapF (W4.SymExpr sym) (W4.SymExpr sym), Maybe (W4.Pred sym))) -> + CallFrameHandle init ret blocks -> + C.BlockID blocks args -> + C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) -> + IORef (ExecutionFeatureContext sym wptr ext) -> + IO (C.ExecutionFeatureResult p sym ext rtp) + +advanceFixpointState bak mem_var maybe_fixpoint_func call_frame_handle block_id sim_state fixpoint_state_ref = do + let sym = C.backendGetSym bak + fixpoint_state <- fromMaybe BeforeFixpoint <$> callFrameContextLookup' call_frame_handle block_id <$> readIORef fixpoint_state_ref + case fixpoint_state of + BeforeFixpoint -> do + ?logMessage $ "SimpleLoopFixpoint: RunningState: BeforeFixpoint -> ComputeFixpoint" + mapM_ (\g -> print =<< C.ppProofObligation sym g) =<< (maybe [] C.goalsToList <$> C.getProofObligations bak) + initializeFixpointState bak mem_var call_frame_handle block_id sim_state fixpoint_state_ref + + ComputeFixpoint fixpoint_record -> do + ?logMessage $ "SimpleLoopFixpoint: RunningState: ComputeFixpoint: " ++ show block_id + proof_goals_and_assumptions_vars <- Set.map (mapSome $ W4.varExpr sym) <$> + (Set.union <$> C.proofObligationsUninterpConstants bak <*> C.pathConditionUninterpConstants bak) + (frame_assumptions, _) <- C.popAssumptionFrameAndObligations bak $ fixpointAssumptionFrameIdentifier fixpoint_record + loop_condition <- C.assumptionsPred sym frame_assumptions + + -- widen the inductive condition + (join_reg_map, join_substitution) <- runFixpointMonad + (joinRegEntries sym + (C.regMap $ fixpointRegMap fixpoint_record) + (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 <- joinMem sym header_mem_impl 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) && Map.keys mem_substitution == Map.keys (fixpointMemSubstitution fixpoint_record) + + -- we found the fixpoint, get ready to wrap up + then do + ?logMessage $ + "SimpleLoopFixpoint: RunningState: ComputeFixpoint -> CheckFixpoint" + + -- 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 + + -- drop variables that don't appear along some back edge + let union_substitution' = 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 + loop_index_linear_substitution <- loopIndexLinearSubstitution sym (fixpointIndex fixpoint_record) union_substitution' + + let union_substitution = MapF.filterWithKey + (\variable _entry -> MapF.notMember variable loop_index_linear_substitution) + union_substitution' + -- try to unify widening variables that have the same values + (normal_substitution', equality_substitution') <- uninterpretedConstantEqualitySubstitution sym union_substitution + + zero_bv <- W4.bvZero sym knownNat + one_bv <- W4.bvOne sym knownNat + add_index_one <- W4.bvAdd sym (fixpointIndex fixpoint_record) one_bv + let normal_substitution = MapF.insert + (fixpointIndex fixpoint_record) + FixpointEntry + { headerValue = zero_bv + , bodyValue = add_index_one + } + normal_substitution' + let equality_substitution = MapF.union equality_substitution' loop_index_linear_substitution + + ?logMessage $ "loop_index_linear_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList loop_index_linear_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 + + let body_values_vars = foldMap (viewSome $ Set.map (mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . bodyValue) $ + MapF.elems normal_substitution + let header_values_vars = foldMap (viewSome $ Set.map (mapSome $ W4.varExpr sym) . W4.exprUninterpConstants sym . headerValue) $ + MapF.elems normal_substitution + -- let all_vars = Set.union proof_goals_and_assumptions_vars $ Set.union body_values_vars header_values_vars + let all_vars' = Set.insert (Some $ fixpointIndex fixpoint_record) proof_goals_and_assumptions_vars + let all_vars = Set.filter + (\(Some variable) -> MapF.notMember variable equality_substitution) + all_vars' + -- let some_uninterpreted_constants = Ctx.fromList $ Set.toList all_vars + let filtered_vars = Set.filter + (\(Some variable) -> + not (List.isPrefixOf "cundefined_" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable) + && not (List.isPrefixOf "cnoSatisfyingWrite" $ show $ W4.printSymExpr variable)) + all_vars + let some_uninterpreted_constants = Ctx.fromList $ Set.toList filtered_vars + -- let implicit_vars = Set.filter + -- (\(Some variable) -> + -- not (List.isPrefixOf "creg_join_var" $ show $ W4.printSymExpr variable) + -- && not (List.isPrefixOf "cmem_join_var" $ show $ W4.printSymExpr variable) + -- && not (List.isPrefixOf "cundefined_" $ show $ W4.printSymExpr variable) + -- && not (List.isPrefixOf "calign_amount" $ show $ W4.printSymExpr variable) + -- && not (List.isPrefixOf "cnoSatisfyingWrite" $ show $ W4.printSymExpr variable)) + -- all_vars + some_inv_pred <- case some_uninterpreted_constants of + Some uninterpreted_constants -> do + inv_pred <- W4.freshTotalUninterpFn + sym + (W4.safeSymbol "inv") + (fmapFC W4.exprType uninterpreted_constants) + W4.BaseBoolRepr + + loc <- W4.getCurrentProgramLoc sym + + header_inv <- W4.applySymFn sym inv_pred $ + applySubstitutionFC (fmapF headerValue normal_substitution) uninterpreted_constants + C.addProofObligation bak $ C.LabeledPred header_inv $ C.SimError loc "" + + inv <- W4.applySymFn sym inv_pred uninterpreted_constants + C.addAssumption bak $ C.GenericAssumption loc "inv" inv + + return $ W4.SomeSymFn inv_pred + + modifyIORef' fixpoint_state_ref $ executionFeatureContextAddInvPred some_inv_pred + + ?logMessage $ + "proof_goals_and_assumptions_vars: " + ++ show (map (viewSome W4.printSymExpr) $ Set.toList proof_goals_and_assumptions_vars) + ?logMessage $ + "body_values_vars: " ++ show (map (viewSome W4.printSymExpr) $ Set.toList body_values_vars) + ?logMessage $ + "header_values_vars: " ++ show (map (viewSome W4.printSymExpr) $ Set.toList header_values_vars) + ?logMessage $ + "uninterpreted_constants: " ++ show (map (viewSome W4.printSymExpr) $ Set.toList filtered_vars) + + modifyIORef' fixpoint_state_ref $ callFrameContextInsert call_frame_handle block_id $ + CheckFixpoint + FixpointRecord + { fixpointBlockId = block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = normal_substitution + , fixpointRegMap = fixpointRegMap fixpoint_record + , fixpointMemSubstitution = mem_substitution + , fixpointEqualitySubstitution = equality_substitution + , fixpointIndex = fixpointIndex fixpoint_record + } + some_inv_pred + -- implicit_vars + some_uninterpreted_constants + loop_condition + + 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 + + modifyIORef' fixpoint_state_ref $ callFrameContextInsert call_frame_handle block_id $ ComputeFixpoint + FixpointRecord + { fixpointBlockId = block_id + , fixpointAssumptionFrameIdentifier = assumption_frame_identifier + , fixpointSubstitution = join_substitution + , fixpointRegMap = C.RegMap join_reg_map + , fixpointMemSubstitution = mem_substitution + , fixpointEqualitySubstitution = MapF.empty + , fixpointIndex = fixpointIndex fixpoint_record + } + 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 + + CheckFixpoint fixpoint_record some_inv_pred some_uninterpreted_constants loop_condition -> 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 (some_inv_pred, some_uninterpreted_constants) of + (W4.SomeSymFn inv_pred, Some uninterpreted_constants) + | Just Refl <- testEquality (W4.fnArgTypes inv_pred) (fmapFC W4.exprType uninterpreted_constants) + , Just Refl <- testEquality (W4.fnReturnType inv_pred) W4.BaseBoolRepr -> do + inv <- W4.applySymFn sym inv_pred $ applySubstitutionFC + (fmapF bodyValue $ fixpointSubstitution fixpoint_record) + uninterpreted_constants + C.addProofObligation bak $ C.LabeledPred inv $ C.SimError loc "" + | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: CheckFixpoint"] + + frame_assumptions <- C.popAssumptionFrame bak $ fixpointAssumptionFrameIdentifier fixpoint_record + + -- body_mem_substitution <- loadMemJoinVariables bak body_mem_impl $ fixpointMemSubstitution fixpoint_record + -- let res_substitution = MapF.mapWithKey + -- (\variable fixpoint_entry -> + -- fixpoint_entry + -- { bodyValue = MapF.findWithDefault (bodyValue fixpoint_entry) variable body_mem_substitution + -- }) + -- (fixpointSubstitution fixpoint_record) + -- ?logMessage $ "res_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr $ bodyValue y)) $ MapF.toList res_substitution) + + -- match things up with the input function that describes the loop body behavior + fixpoint_substitution <- case maybe_fixpoint_func of + Just fixpoint_func -> do + -- (fixpoint_func_substitution, maybe_fixpoint_func_condition) <- fixpoint_func res_substitution loop_condition + + correct_substitution <- traverseF + (\fixpoint_entry -> do + correct_body_value <- W4.substituteBoundVars sym (asBoundVarSubstitution sym $ fixpointEqualitySubstitution fixpoint_record) $ bodyValue fixpoint_entry + return $ fixpoint_entry + { bodyValue = correct_body_value + }) + (fixpointSubstitution fixpoint_record) + (fixpoint_func_substitution, maybe_fixpoint_func_condition) <- fixpoint_func correct_substitution loop_condition + -- (fixpoint_func_substitution, maybe_fixpoint_func_condition) <- fixpoint_func (fixpointSubstitution fixpoint_record) loop_condition + + _ <- case maybe_fixpoint_func_condition of + Just fixpoint_func_condition -> do + bak_assumptions <- liftIO $ C.assumptionsPred sym =<< C.collectAssumptions bak + inv_assumption <- C.assumptionPred <$> headAssumption sym frame_assumptions + all_assumptions <- liftIO $ W4.andPred sym bak_assumptions inv_assumption + implication <- liftIO $ W4.impliesPred sym all_assumptions fixpoint_func_condition + modifyIORef' fixpoint_state_ref $ executionFeatureContextAddLoopFunEquivCond implication + -- tmp_frame_id <- C.pushAssumptionFrame bak + -- C.addProofObligation bak $ C.LabeledPred fixpoint_func_condition $ C.SimError loc "" + -- (_, obligations) <- C.popAssumptionFrameAndObligations bak tmp_frame_id + -- ?logMessage "before convertProofObligationsAsImplications" + -- implications <- C.convertProofObligationsAsImplications sym obligations + -- ?logMessage "after convertProofObligationsAsImplications" + -- forM_ implications $ \implication -> + -- modifyIORef' fixpoint_state_ref $ executionFeatureContextAddLoopFunEquivCond implication + Nothing -> return () + + ?logMessage $ "fixpoint_func_substitution: " ++ show (map (\(MapF.Pair x y) -> (W4.printSymExpr x, W4.printSymExpr y)) $ MapF.toList fixpoint_func_substitution) + + return fixpoint_func_substitution + + Nothing -> return MapF.empty + + 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 + + fixpoint_equality_substitution <- traverseF + (W4.substituteBoundVars sym $ asBoundVarSubstitution sym fixpoint_substitution) $ + fixpointEqualitySubstitution fixpoint_record + let fixpoint_equality_substitution' = MapF.union fixpoint_substitution fixpoint_equality_substitution + let res_reg_map = C.RegMap $ applySubstitutionRegEntries sym fixpoint_equality_substitution' (C.regMap $ fixpointRegMap fixpoint_record) + res_mem_impl <- storeMemJoinVariables bak header_mem_impl (fixpointMemSubstitution fixpoint_record) fixpoint_equality_substitution' + + (_ :: ()) <- case (some_inv_pred, some_uninterpreted_constants) of + (W4.SomeSymFn inv_pred, Some uninterpreted_constants) + | Just Refl <- testEquality (W4.fnArgTypes inv_pred) (fmapFC W4.exprType uninterpreted_constants) + , Just Refl <- testEquality (W4.fnReturnType inv_pred) W4.BaseBoolRepr -> do + inv <- W4.applySymFn sym inv_pred $ applySubstitutionFC fixpoint_substitution uninterpreted_constants + C.addAssumption bak $ C.GenericAssumption loc "" inv + | otherwise -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint" ["type mismatch: CheckFixpoint"] + + modifyIORef' fixpoint_state_ref $ callFrameContextInsert call_frame_handle block_id $ + AfterFixpoint + -- fixpoint_record{ fixpointSubstitution = res_substitution } + fixpoint_record + + 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 + + AfterFixpoint{} -> do + ?logMessage $ "SimpleLoopFixpoint: RunningState: AfterFixpoint -> ComputeFixpoint" + initializeFixpointState bak mem_var call_frame_handle block_id sim_state fixpoint_state_ref + + +handleSymbolicBranch :: + (C.IsSymBackend sym bak, C.HasPtrWidth wptr, KnownNat wptr, C.HasLLVMAnn sym, ?memOpts :: C.MemOptions, ?logMessage :: String -> IO ()) => + bak -> + CallFrameHandle init ret blocks -> + C.BlockID blocks tp -> + W4.Pred sym -> + C.PausedFrame p sym ext rtp (C.CrucibleLang blocks r) -> + C.PausedFrame p sym ext rtp (C.CrucibleLang blocks r) -> + Maybe (C.Some (C.BlockID blocks)) -> + Maybe (C.Some (C.BlockID blocks)) -> + C.SimState p sym ext rtp (C.CrucibleLang blocks r) ('Just args) -> + IORef (ExecutionFeatureContext sym wptr ext) -> + IO (C.ExecutionFeatureResult p sym ext rtp) +handleSymbolicBranch bak call_frame_handle loop_block_id branch_condition true_frame false_frame true_frame_parent_loop_id false_frame_parent_loop_id sim_state fixpoint_state_ref = do + let sym = C.backendGetSym bak + + (loop_condition, inside_loop_frame, outside_loop_frame) <- + if true_frame_parent_loop_id == Just (C.Some loop_block_id) + then + return (branch_condition, true_frame, false_frame) + else if false_frame_parent_loop_id == Just (C.Some loop_block_id) + then do + not_branch_condition <- W4.notPred sym branch_condition + return (not_branch_condition, false_frame, true_frame) + else + fail $ "unsupported loop: loop header block id " ++ show loop_block_id ++ " true frame parent loop id " ++ show true_frame_parent_loop_id ++ " false frame parent loop id " ++ show false_frame_parent_loop_id + + Just fixpoint_state <- callFrameContextLookup' call_frame_handle loop_block_id <$> readIORef fixpoint_state_ref + (condition, frame) <- case fixpoint_state of + BeforeFixpoint -> C.panic "SimpleLoopFixpoint.simpleLoopFixpoint:" ["BeforeFixpoint"] + + ComputeFixpoint{} -> do + -- continue in the loop + ?logMessage "SimpleLoopFixpoint: SymbolicBranchState: ComputeFixpoint" + return (loop_condition, inside_loop_frame) + + CheckFixpoint fixpoint_record some_inv_pred some_uninterpreted_constants _ -> do + -- continue in the loop + ?logMessage "SimpleLoopFixpoint: SymbolicBranchState: CheckFixpoint" + modifyIORef' fixpoint_state_ref $ callFrameContextInsert call_frame_handle loop_block_id $ + CheckFixpoint fixpoint_record some_inv_pred some_uninterpreted_constants loop_condition + return (loop_condition, inside_loop_frame) + + AfterFixpoint{} -> do + -- break out of the loop + ?logMessage "SimpleLoopFixpoint: SymbolicBranchState: AfterFixpoint" + modifyIORef' fixpoint_state_ref $ callFrameContextPop call_frame_handle + 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 + + +data SomeCallFrameHandle ret blocks = forall init . SomeCallFrameHandle (CallFrameHandle init ret blocks) + +callFrameHandle :: C.CallFrame sym ext blocks ret ctx -> SomeCallFrameHandle ret blocks +callFrameHandle C.CallFrame { _frameCFG = g } = + SomeCallFrameHandle $ CallFrameHandle (C.cfgHandle g) $ fmapFC C.blockInputs $ C.cfgBlockMap g + +data MaybePausedFrameTgtId f where + JustPausedFrameTgtId :: C.Some (C.BlockID b) -> MaybePausedFrameTgtId (C.CrucibleLang b r) + NothingPausedFrameTgtId :: MaybePausedFrameTgtId f + +pausedFrameTgtId :: C.PausedFrame p sym ext rtp f -> MaybePausedFrameTgtId f +pausedFrameTgtId 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 + + +applySubstitutionFC :: (OrdF k, FunctorFC f) => MapF k k -> f k l -> f k l +applySubstitutionFC substitution = fmapFC $ findWithDefaultKey substitution + +findWithDefaultKey :: forall a (k :: a -> Type) tp . OrdF k => MapF k k -> k tp -> k tp +findWithDefaultKey substitution key = MapF.findWithDefault key key substitution + +asBoundVarSubstitution :: W4.IsSymExprBuilder sym => sym -> MapF (W4.SymExpr sym) a -> MapF (W4.BoundVar sym) a +asBoundVarSubstitution sym = + MapF.fromList . mapMaybe (\(MapF.Pair k_expr v) -> fmap (\k_var -> MapF.Pair k_var v) $ asBoundVar sym k_expr) . MapF.toList + +asBoundVar :: W4.IsSymExprBuilder sym => sym -> W4.SymExpr sym tp -> Maybe (W4.BoundVar sym tp) +asBoundVar sym expr = case Set.toList (W4.exprUninterpConstants sym expr) of + [Some var] + | Just Refl <- testEquality expr (W4.varExpr sym var) -> + Just var + _ -> Nothing + +headAssumption :: sym -> C.Assumptions sym -> IO (C.CrucibleAssumption (W4.SymExpr sym)) +headAssumption sym = \case + C.SingleAssumption a -> return a + C.ManyAssumptions (x Seq.:<| _) -> headAssumption sym x + _ -> fail "SimpleLoopFixpoint.headAssumption: empty assumptions" diff --git a/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs --- a/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs +++ b/src/Lang/Crucible/LLVM/SimpleLoopInvariant.hs @@ -518,7 +518,7 @@ 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 + p0 <- C.ptrIsBv sym v' p' <- W4.andPred sym p p0 W4.bvIte sym p' (C.llvmPointerOffset v') def diff --git a/src/Lang/Crucible/LLVM/SymIO.hs b/src/Lang/Crucible/LLVM/SymIO.hs --- a/src/Lang/Crucible/LLVM/SymIO.hs +++ b/src/Lang/Crucible/LLVM/SymIO.hs @@ -401,24 +401,23 @@ openFile :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => LLVMFileSystem wptr - -> LLVMOverride p sym + -> LLVMOverride p sym ext (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) + (\memOps args -> uncurryAssignment (callOpenFile memOps fsVars) args) callOpenFile :: - (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => - bak -> + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => 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 = +callOpenFile memOps fsVars filename_ptr _flags = do fileIdent <- loadFileIdent memOps (regValue filename_ptr) SymIO.openFile (llvmFileSystem fsVars) fileIdent $ \case Left SymIO.FileNotFound -> returnIOError32 @@ -427,22 +426,21 @@ closeFile :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => LLVMFileSystem wptr - -> LLVMOverride p sym + -> LLVMOverride p sym ext (EmptyCtx ::> BVType 32) (BVType 32) closeFile fsVars = [llvmOvr| i32 @close( i32 ) |] - (\memOps bak args -> uncurryAssignment (callCloseFile bak memOps fsVars) args) + (\memOps args -> uncurryAssignment (callCloseFile memOps fsVars) args) callCloseFile :: - (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) => - bak -> + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => 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 +callCloseFile _memOps fsVars filedesc = + do sym <- getSymInterface lookupFileHandle fsVars (regValue filedesc) emptyRegMap $ \case Just fileHandle -> \_ -> SymIO.closeFileHandle (llvmFileSystem fsVars) fileHandle $ \case @@ -453,36 +451,36 @@ readFileHandle :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => LLVMFileSystem wptr - -> LLVMOverride p sym + -> LLVMOverride p sym ext (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) + (\memOps args -> uncurryAssignment (callReadFileHandle memOps fsVars) args) callReadFileHandle :: - (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr) => - bak -> + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr) => 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 +callReadFileHandle memOps fsVars filedesc buf count = + do sym <- getSymInterface 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') + ovrWithBackend $ \bak -> + 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 @@ -523,34 +521,34 @@ writeFileHandle :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => LLVMFileSystem wptr - -> LLVMOverride p sym + -> LLVMOverride p sym ext (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) + (\memOps args -> uncurryAssignment (callWriteFileHandle memOps fsVars) args) callWriteFileHandle :: - (IsSymBackend sym bak, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => - bak -> + (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, ?memOpts :: MemOptions) => 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 = +callWriteFileHandle 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 + ovrWithBackend $ \bak -> do + 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 @@ -559,7 +557,7 @@ symio_overrides :: (IsSymInterface sym, HasLLVMAnn sym, HasPtrWidth wptr, wptr ~ ArchWidth arch, ?memOpts :: MemOptions) => LLVMFileSystem wptr - -> [OverrideTemplate p sym arch rtp l a] + -> [OverrideTemplate p sym ext arch] symio_overrides fs = [ basic_llvm_override $ openFile fs , basic_llvm_override $ closeFile fs diff --git a/src/Lang/Crucible/LLVM/Translation/Expr.hs b/src/Lang/Crucible/LLVM/Translation/Expr.hs --- a/src/Lang/Crucible/LLVM/Translation/Expr.hs +++ b/src/Lang/Crucible/LLVM/Translation/Expr.hs @@ -101,7 +101,6 @@ import Lang.Crucible.Syntax import Lang.Crucible.Types -import What4.InterpretedFloatingPoint (X86_80Val(..)) ------------------------------------------------------------------------- -- LLVMExpr diff --git a/src/Lang/Crucible/LLVM/Translation/Instruction.hs b/src/Lang/Crucible/LLVM/Translation/Instruction.hs --- a/src/Lang/Crucible/LLVM/Translation/Instruction.hs +++ b/src/Lang/Crucible/LLVM/Translation/Instruction.hs @@ -1073,6 +1073,7 @@ continueLambda c_label (branch cond bv_label ptr_label) atomicRWOp :: + forall s arch ret. L.AtomicRWOp -> LLVMExpr s arch -> LLVMExpr s arch -> @@ -1083,26 +1084,133 @@ | 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 + newval <- bvOp w xbv ybv return $ BaseExpr (LLVMPointerRepr w) $ BitvectorAsPointerExpr w newval + (Scalar _archProxy (FloatRepr fi) xf, Scalar _archPrxy' (FloatRepr fi') yf) + | Just Refl <- testEquality fi fi' + -> do newval <- floatingOp fi xf yf + return $ BaseExpr (FloatRepr fi) newval + _ -> fail $ unlines [ "atomicRW operation on incompatible values" , "Operation: " ++ show op , "Value 1: " ++ show x , "Value 2: " ++ show y ] + where + -- Translate an atomic operation over bitvector values, respecting the + -- semantics described in this part of the LLVM Language Reference Manual: + -- https://releases.llvm.org/16.0.0/docs/LangRef.html#id229 + -- + -- Note that `xbv` corresponds to `*ptr` and `ybv` corresponds to `val` in + -- the Reference Manual. + bvOp :: + forall w. + (1 <= w) => + NatRepr w -> + Expr LLVM s (BVType w) -> + Expr LLVM s (BVType w) -> + LLVMGenerator s arch ret (Expr LLVM s (BVType w)) + bvOp w xbv ybv = + case op of + L.AtomicXchg -> pure ybv + L.AtomicAdd -> pure $ app $ BVAdd w xbv ybv + L.AtomicSub -> pure $ app $ BVSub w xbv ybv + L.AtomicAnd -> pure $ app $ BVAnd w xbv ybv + L.AtomicNand -> pure $ app $ BVNot w $ app $ BVAnd w xbv ybv + L.AtomicOr -> pure $ app $ BVOr w xbv ybv + L.AtomicXor -> pure $ app $ BVXor w xbv ybv + L.AtomicMax -> pure $ app $ BVSMax w xbv ybv + L.AtomicMin -> pure $ app $ BVSMin w xbv ybv + L.AtomicUMax -> pure $ app $ BVUMax w xbv ybv + L.AtomicUMin -> pure $ app $ BVUMin w xbv ybv + L.AtomicUIncWrap -> + -- This is the same thing as + -- + -- (*ptr u>= val) ? 0 : (*ptr + 1) + -- + -- from the LLVM semantics, but with a double-negated condition to + -- account for the Crucible CFG language not having a BVUge operation + -- (only BVUlt). + let c = app $ Not $ app $ BVUlt w xbv ybv -- ~(*ptr u< val) + t = zero + f = app $ BVAdd w xbv one in + pure $ app $ BVIte c w t f + L.AtomicUDecWrap -> + -- This is the same thing as + -- + -- ((*ptr == 0) || (*ptr u> val)) ? val : (*ptr - 1) + -- + -- from the LLVM semantics, but with a double-negated condition to + -- account for the Crucible CFG language not having a BVUgt operation + -- (only BVUle). + let c1 = app $ BVEq w xbv zero + c2 = app $ Not $ app $ BVUle w xbv ybv -- ~(*ptr u<= val) + c = app $ Or c1 c2 + t = xbv + f = app $ BVSub w xbv one in + pure $ app $ BVIte c w t f + L.AtomicFAdd -> nonBvError + L.AtomicFSub -> nonBvError + L.AtomicFMax -> nonBvError + L.AtomicFMin -> nonBvError + where + zero, one :: Expr LLVM s (BVType w) + zero = app $ BVLit w $ BV.zero w + one = app $ BVLit w $ BV.one w + + nonBvError :: forall a. LLVMGenerator s arch ret a + nonBvError = + reportError $ fromString $ unwords + [ "Invalid atomic bitvector operation" + , "Operation: " ++ show op + , "Value 1: " ++ show xbv + , "Value 2: " ++ show ybv + ] + + -- Translate an atomic operation over floating-point values, respecting the + -- semantics described in this part of the LLVM Language Reference Manual: + -- https://releases.llvm.org/16.0.0/docs/LangRef.html#id229 + -- + -- Note that `xf` corresponds to `*ptr` and `yf` corresponds to `val` in the + -- Reference Manual. + floatingOp :: + forall fi. + FloatInfoRepr fi -> + Expr LLVM s (FloatType fi) -> + Expr LLVM s (FloatType fi) -> + LLVMGenerator s arch ret (Expr LLVM s (FloatType fi)) + floatingOp fi xf yf = + case op of + L.AtomicXchg -> pure yf + L.AtomicFAdd -> pure $ app $ FloatAdd fi RNE xf yf + L.AtomicFSub -> pure $ app $ FloatSub fi RNE xf yf + L.AtomicFMax -> pure $ app $ FloatMax fi xf yf + L.AtomicFMin -> pure $ app $ FloatMin fi xf yf + + L.AtomicAdd -> nonFloatingError + L.AtomicSub -> nonFloatingError + L.AtomicAnd -> nonFloatingError + L.AtomicNand -> nonFloatingError + L.AtomicOr -> nonFloatingError + L.AtomicXor -> nonFloatingError + L.AtomicMax -> nonFloatingError + L.AtomicMin -> nonFloatingError + L.AtomicUMax -> nonFloatingError + L.AtomicUMin -> nonFloatingError + L.AtomicUIncWrap -> nonFloatingError + L.AtomicUDecWrap -> nonFloatingError + where + nonFloatingError :: forall a. LLVMGenerator s arch ret a + nonFloatingError = + reportError $ fromString $ unwords + [ "Invalid atomic floating-point operation" + , "Operation: " ++ show op + , "Value 1: " ++ show xf + , "Value 2: " ++ show yf + ] + floatingCompare :: L.FCmpOp -> MemType -> @@ -1713,6 +1821,9 @@ ptr' <- transTypedValue ptr case valTy of IntType _ -> pure () + FloatType -> pure () + DoubleType -> pure () + X86_FP80Type -> pure () _ -> fail $ unwords ["Invalid argument type on atomicrw, expected integer type", show ptr] llvmTypeAsRepr valTy $ \expectTy -> @@ -1942,6 +2053,8 @@ , "llvm.dbg.declare" , "llvm.dbg.addr" , "llvm.dbg.value" + , "llvm.dbg.assign" -- Added in LLVM 16 + , "llvm.experimental.noalias.scope.decl" -- Added in LLVM 12 , "llvm.lifetime.start" , "llvm.lifetime.start.p0" , "llvm.lifetime.start.p0i8" diff --git a/src/Lang/Crucible/LLVM/Utils.hs b/src/Lang/Crucible/LLVM/Utils.hs --- a/src/Lang/Crucible/LLVM/Utils.hs +++ b/src/Lang/Crucible/LLVM/Utils.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + ------------------------------------------------------------------------ -- | -- Module : Lang.Crucible.LLVM.Utils @@ -7,9 +11,35 @@ -- Maintainer : Rob Dockins -- Stability : provisional ------------------------------------------------------------------------ -module Lang.Crucible.LLVM.Utils (applyUnless) where +module Lang.Crucible.LLVM.Utils + ( applyUnless + , sextendBVTo + ) where +import What4.Interface + +import Lang.Crucible.Backend +import Lang.Crucible.Panic (panic) + -- | 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 + +-- | Convert a 'SymBV' value of width @w@ to width @w'@, performing sign +-- extension or truncation as needed. +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' + ] diff --git a/test/TestMemory.hs b/test/TestMemory.hs --- a/test/TestMemory.hs +++ b/test/TestMemory.hs @@ -134,7 +134,7 @@ 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) + ptr_i' <- ptrAdd sym ?ptrWidth ptr_i =<< What4.bvOne sym ?ptrWidth zero_bv <- What4.bvLit sym (knownNat @8) (BV.zero knownNat) mem3 <- @@ -149,7 +149,7 @@ 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) + ptr_j' <- ptrAdd sym ?ptrWidth ptr_j =<< What4.bvOne sym ?ptrWidth at_j_val <- projectLLVM_bv bak =<< doLoad bak mem4 ptr_j byte_storage_type ptr_byte_repr noAlignment @@ -329,7 +329,7 @@ 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 + zero_bv <- What4.bvZero sym ?ptrWidth expected_arr <- What4.arrayCopy sym dst_arr i src_arr zero_bv len expected_val <- What4.arrayLookup sym expected_arr $ Ctx.singleton i