diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Tristan Ravitch + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tristan Ravitch nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# Introduction + +A Haskell library for analyzing LLVM bitcode. To convert bitcode the +format used by this library, see the llvm-data-interop package and the +haddocks for the LLVM.Analysis module. + +This library attempts to provide some basic program analysis +infrastructure and aims to scale to large bitcode files. Additional +analysis tools are welcome. + +# A note on testing + +Some tests in the test suite necessarily rely on names generated by +the frontend used to generate bitcode. These internal names are not +stable and change with each frontend release. The test suite +currently runs with clang 3.2. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/llvm-analysis.cabal b/llvm-analysis.cabal new file mode 100644 --- /dev/null +++ b/llvm-analysis.cabal @@ -0,0 +1,172 @@ +name: llvm-analysis +version: 0.3.0 +synopsis: A Haskell library for analyzing LLVM bitcode +license: BSD3 +license-file: LICENSE +author: Tristan Ravitch +maintainer: travitch@cs.wisc.edu +category: Development +build-type: Simple +cabal-version: >=1.10 +stability: experimental +tested-with: GHC == 7.6.3 +extra-source-files: README.md +description: A Haskell library for analyzing LLVM bitcode. To convert + bitcode to the format used by this library, see the + llvm-data-interop package. + . + This library attempts to provide some basic program analysis + infrastructure and aims to scale to large bitcode files. + . + There are some useful tools built on top of this library + available in the llvm-tools package. + . + Changes since 0.2.0: + + * LLVM 3.3 support (contributed by Patrick Hulin) + + * Metadata format change. Metadata type entries no longer have + a MetaDWFile. Instead, file and directory names are stored + directly in each MetaDW*Type. This change lets us more easily + accommodate changes in LLVM 3.3 (while supporting older versions). + + * Under LLVM 3.3, the 'metaCompileUnitIsMain' field of MetaDWCompileUnit + is always False. This disappeared in LLVM 3.3, but removing it would + be an unnecessary API break, I think. + +flag DebugAndersenConstraints + description: Enable debugging output for the points-to analysis (shows constraints) + default: False + +flag DebugAndersenGraph + description: Enable debugging output for the points-to analysis (shows the solved constraint graph in a window) + default: False + +library + default-language: Haskell2010 + build-depends: base == 4.*, + vector >= 0.9, + transformers >= 0.3, + filemanip >= 0.3.5.2, + monad-par >= 0.3.4.2, + graphviz >= 2999.12.0.3, + temporary >= 1.0, + lens > 1, + hashable >= 1.1.2.0, + failure >= 0.2, + lens >= 3.8, + GenericPretty > 1, + hoopl >= 3.9.0.0, + llvm-base-types >= 0.3.0, + fgl >= 5.4, + text >= 0.11, + boomerang, + ifscs >= 0.2.0.0 && < 0.3.0.0, + array, bytestring, containers, deepseq, + process, filepath, directory, unordered-containers, + -- Testing + HUnit, test-framework, test-framework-hunit, + -- Dealing with C++ names + itanium-abi >= 0.1.0.0 && < 0.2.0.0, + uniplate == 1.* + hs-source-dirs: src + exposed-modules: LLVM.Analysis, + LLVM.Analysis.AccessPath, + LLVM.Analysis.BlockReturnValue, + LLVM.Analysis.CDG, + LLVM.Analysis.CFG, + LLVM.Analysis.CFG.Internal, + LLVM.Analysis.CallGraph, + LLVM.Analysis.CallGraphSCCTraversal, + LLVM.Analysis.CallGraph.Internal, + LLVM.Analysis.ClassHierarchy, + LLVM.Analysis.Dataflow, + LLVM.Analysis.Dominance, + LLVM.Analysis.PointsTo, + LLVM.Analysis.PointsTo.AllocatorProfile, + LLVM.Analysis.PointsTo.Andersen, + LLVM.Analysis.PointsTo.TrivialFunction, + LLVM.Analysis.NoReturn, + LLVM.Analysis.NullPointers, + LLVM.Analysis.ScalarEffects, + LLVM.Analysis.UsesOf, + LLVM.Analysis.Util.Names, + LLVM.Analysis.Util.Testing + + if flag(DebugAndersenConstraints) + cpp-options: "-DDEBUGCONSTRAINTS" + ghc-options: -Wall -funbox-strict-fields + ghc-prof-options: -auto-all + +test-suite CallGraphTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: CallGraphTest.hs + hs-source-dirs: tests + build-depends: base == 4.*, + HUnit, filepath, containers, bytestring, + llvm-analysis >= 0.3.0, + llvm-data-interop >= 0.3.0 + ghc-options: -Wall + +test-suite BlockReturnTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: BlockReturnTests.hs + hs-source-dirs: tests + build-depends: base == 4.*, + containers, HUnit, filepath, + llvm-analysis >= 0.3.0, + llvm-data-interop >= 0.3.0 + ghc-options: -Wall + +test-suite ReturnTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base == 4.*, + transformers >= 0.3, + containers, filepath, HUnit, + unordered-containers, + llvm-data-interop >= 0.3.0, + llvm-analysis >= 0.3.0 + ghc-options: -Wall -rtsopts + main-is: ReturnTests.hs + hs-source-dirs: tests + +test-suite AccessPathTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base == 4.*, + containers, filepath, HUnit, + llvm-data-interop >= 0.3.0, + llvm-analysis >= 0.3.0 + ghc-options: -Wall -rtsopts + main-is: AccessPathTests.hs + hs-source-dirs: tests + +test-suite ClassHierarchyTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base == 4.*, + containers, filepath, HUnit, uniplate, + llvm-analysis >= 0.3.0, + llvm-data-interop >= 0.3.0, + itanium-abi + ghc-options: -Wall -rtsopts + main-is: ClassHierarchyTests.hs + hs-source-dirs: tests + +test-suite AndersenTests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base == 4.*, + containers, filepath, HUnit, + llvm-data-interop >= 0.3.0, + llvm-analysis >= 0.3.0 + + if flag(DebugAndersenGraph) + build-depends: graphviz + cpp-options: "-DDEBUGGRAPH" + ghc-options: -Wall + main-is: AndersenTest.hs + hs-source-dirs: tests diff --git a/src/LLVM/Analysis.hs b/src/LLVM/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis.hs @@ -0,0 +1,81 @@ +-- | This top-level module exports the LLVM IR definitions and some +-- basic functions to inspect the IR. The sub-modules under +-- LLVM.Analysis provide higher-level tools for analyzing the IR. +module LLVM.Analysis ( + -- * Parsing LLVM Bitcode + -- $parsing + + -- * Types + module Data.LLVM.Types, + + -- * Extra helpers + FuncLike(..), + ToGraphviz(..) + ) where + +import Data.GraphViz ( DotGraph ) +import Data.LLVM.Types + +-- | A class for types that can be derived from a Function. +class FuncLike a where + fromFunction :: Function -> a + +instance FuncLike Function where + fromFunction = id + +-- | A class for things that can be converted to graphviz graphs +class ToGraphviz a where + toGraphviz :: a -> DotGraph Int + +-- $parsing +-- +-- The functions to parse LLVM Bitcode into a Haskell ADT are in the +-- llvm-data-interop package (in the "LLVM.Parse" module). The first +-- is 'parseLLVMFile': +-- +-- > import LLVM.Parse +-- > main = do +-- > m <- parseLLVMFile defaultParserOptions filePath +-- > either error analyzeModule +-- > +-- > analyzeModule :: Module -> IO () +-- +-- The 'defaultParserOptions' direct the parser to keep all metadata. +-- This behavior can be changed to discard the location metadata +-- normally attached to each instruction, saving a great deal of +-- space. Metadata describing the source-level types of functions, +-- arguments, and local variables (among other things) is preserved. +-- If the module was compiled without debug information, no metadata +-- will be parsed at all. +-- +-- There are two variants of 'parseLLVMFile': +-- +-- * 'hParseLLVMFile' parses its input from a 'Handle' instead of +-- a named file. +-- +-- * 'parseLLVM' parses its input from a (strict) 'ByteString'. +-- +-- There is also a higher-level wrapper in +-- "LLVM.Analysis.Util.Testing": +-- +-- > import LLVM.Analysis.Util.Testing +-- > import LLVM.Parse +-- > main = do +-- > m <- buildModule ["-mem2reg", "-gvn"] (parseLLVMFile defaultParserOptions) filePath +-- > either error analyzeModule +-- +-- This wrapper function accepts both LLVM Bitcode and C/C++ source +-- files. Source files are compiled with clang into bitcode; the +-- resulting bitcode is fed to the @opt@ binary, which is passed the +-- options in the first argument to 'buildModule'. +-- +-- By default, this helper calls binaries named @clang@, @clang++@, +-- and @opt@, which are expected to be in your @PATH@. To accommodate +-- distro packages, additional names are searched for @opt@: +-- @opt-3.2@, @opt-3.1@, and @opt-3.0@. +-- +-- If you cannot place these binaries in your @PATH@, or if your +-- binaries have different names, you can specify them (either using +-- absolute or relative paths) with the environment variables +-- @LLVM_CLANG@, @LLVM_CLANGXX@, and @LLVM_OPT@. These environment +-- variables override any default searching. diff --git a/src/LLVM/Analysis/AccessPath.hs b/src/LLVM/Analysis/AccessPath.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/AccessPath.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} +-- | This module defines an abstraction over field accesses of +-- structures called AccessPaths. A concrete access path is rooted at +-- a value, while an abstract access path is rooted at a type. Both +-- include a list of 'AccessType's that denote dereferences of +-- pointers, field accesses, and array references. +module LLVM.Analysis.AccessPath ( + -- * Types + AccessPath(..), + accessPathComponents, + AbstractAccessPath(..), + abstractAccessPathComponents, + AccessType(..), + AccessPathError(..), + -- * Constructor + accessPath, + abstractAccessPath, + appendAccessPath, + followAccessPath, + reduceAccessPath, + externalizeAccessPath + ) where + +import Control.DeepSeq +import Control.Exception +import Control.Failure hiding ( failure ) +import qualified Control.Failure as F +import Data.Hashable +import qualified Data.List as L +import qualified Data.Text as T +import Data.Typeable +import Text.PrettyPrint.GenericPretty + +import LLVM.Analysis + +-- import Text.Printf +-- import Debug.Trace +-- debug = flip trace + +data AccessPathError = NoPathError Value + | NotMemoryInstruction Instruction + | CannotFollowPath AbstractAccessPath Value + | BaseTypeMismatch Type Type + | NonConstantInPath AbstractAccessPath Value + | EndpointTypeMismatch Type Type + | IrreducableAccessPath AbstractAccessPath + | CannotExternalizeType Type + deriving (Typeable, Show) + +instance Exception AccessPathError + +-- | The sequence of field accesses used to reference a field +-- structure. +data AbstractAccessPath = + AbstractAccessPath { abstractAccessPathBaseType :: Type + , abstractAccessPathEndType :: Type + , abstractAccessPathTaggedComponents :: [(Type, AccessType)] + } + deriving (Eq, Ord, Generic) + +abstractAccessPathComponents :: AbstractAccessPath -> [AccessType] +abstractAccessPathComponents = map snd . abstractAccessPathTaggedComponents + +instance Out AbstractAccessPath +instance Show AbstractAccessPath where + show = pretty + +instance Hashable AbstractAccessPath where + hashWithSalt s (AbstractAccessPath bt et cs) = + s `hashWithSalt` bt `hashWithSalt` et `hashWithSalt` cs + +appendAccessPath :: (Failure AccessPathError m) + => AbstractAccessPath + -> AbstractAccessPath + -> m AbstractAccessPath +appendAccessPath (AbstractAccessPath bt1 et1 cs1) (AbstractAccessPath bt2 et2 cs2) = + case et1 == bt2 of + True -> return $ AbstractAccessPath bt1 et2 (cs1 ++ cs2) + False -> F.failure $ EndpointTypeMismatch et1 bt2 + +-- | If the access path has more than one field access component, take +-- the first field access and the base type to compute a new base type +-- (the type of the indicated field) and the rest of the path +-- components. Also allows for the discarding of array accesses. +-- +-- Each call reduces the access path by one component +reduceAccessPath :: (Failure AccessPathError m) + => AbstractAccessPath -> m AbstractAccessPath +reduceAccessPath (AbstractAccessPath (TypePointer t _) et ((_, AccessDeref):cs)) = + return $! AbstractAccessPath t et cs +-- FIXME: Some times (e.g., pixmap), the field number is out of range. +-- Have to figure out what could possibly cause that. Until then, just +-- ignore those cases. Users of this are working at best-effort anyway. +reduceAccessPath p@(AbstractAccessPath (TypeStruct _ ts _) et ((_,AccessField fldNo):cs)) = + case fldNo < length ts of + True -> return $! AbstractAccessPath (ts !! fldNo) et cs + False -> F.failure $ IrreducableAccessPath p +reduceAccessPath (AbstractAccessPath (TypeArray _ t) et ((_,AccessArray):cs)) = + return $! AbstractAccessPath t et cs +reduceAccessPath p = F.failure $ IrreducableAccessPath p + +instance NFData AbstractAccessPath where + rnf a@(AbstractAccessPath _ _ ts) = ts `deepseq` a `seq` () + +data AccessPath = + AccessPath { accessPathBaseValue :: Value + , accessPathBaseType :: Type + -- ^ If there are some wonky bitcasts in play, this + -- type records the real type of this path, even if the + -- base was something unrelated and bitcast. The real + -- type is the type casted /to/. + , accessPathEndType :: Type + , accessPathTaggedComponents :: [(Type, AccessType)] + } + deriving (Generic, Eq, Ord) + +accessPathComponents :: AccessPath -> [AccessType] +accessPathComponents = map snd . accessPathTaggedComponents + +instance Out AccessPath +instance Show AccessPath where + show = pretty + +instance NFData AccessPath where + rnf a@(AccessPath _ _ _ ts) = ts `deepseq` a `seq` () + +instance Hashable AccessPath where + hashWithSalt s (AccessPath bv bt ev cs) = + s `hashWithSalt` bv `hashWithSalt` bt `hashWithSalt` ev `hashWithSalt` cs + +data AccessType = AccessField !Int + -- ^ Field access of the field with this index + | AccessUnion + -- ^ A union access. The union discriminator is the + -- /type/ that this AccessType is tagged with in the + -- AccessPath. Unions in LLVM do not have an + -- explicit representation of their fields, so there + -- is no index possible here. + | AccessArray + -- ^ An array access; all array elements are treated + -- as a unit + | AccessDeref + -- ^ A plain pointer dereference + deriving (Read, Show, Eq, Ord, Generic) + +instance Out AccessType + +instance NFData AccessType where + rnf a@(AccessField i) = i `seq` a `seq` () + rnf _ = () + +instance Hashable AccessType where + hashWithSalt s (AccessField ix) = + s `hashWithSalt` (1 :: Int) `hashWithSalt` ix + hashWithSalt s AccessUnion = s `hashWithSalt` (154 :: Int) + hashWithSalt s AccessArray = s `hashWithSalt` (26 :: Int) + hashWithSalt s AccessDeref = s `hashWithSalt` (300 :: Int) + +followAccessPath :: (Failure AccessPathError m) => AbstractAccessPath -> Value -> m Value +followAccessPath aap@(AbstractAccessPath bt _ components) val = + case derefPointerType bt /= valueType val of + True -> F.failure (BaseTypeMismatch bt (valueType val)) + False -> walk components val + where + walk [] v = return v + walk ((_, AccessField ix) : rest) v = + case valueContent' v of + ConstantC ConstantStruct { constantStructValues = vs } -> + case ix < length vs of + False -> error $ concat [ "LLVM.Analysis.AccessPath.followAccessPath.walk: " + ," Invalid access path: ", show aap, " / ", show val + ] + True -> walk rest (vs !! ix) + _ -> F.failure (NonConstantInPath aap val) + walk _ _ = F.failure (CannotFollowPath aap val) + +abstractAccessPath :: AccessPath -> AbstractAccessPath +abstractAccessPath (AccessPath _ vt t p) = + AbstractAccessPath vt t p + +-- | For Store, RMW, and CmpXchg instructions, the returned access +-- path describes the field /stored to/. For Load instructions, the +-- returned access path describes the field loaded. For +-- GetElementPtrInsts, the returned access path describes the field +-- whose address was taken/computed. +accessPath :: (Failure AccessPathError m) => Instruction -> m AccessPath +accessPath i = + case i of + StoreInst { storeAddress = sa, storeValue = sv } -> + return $! addDeref $ go (AccessPath sa (valueType sa) (valueType sv) []) (valueType sa) sa + LoadInst { loadAddress = la } -> + return $! addDeref $ go (AccessPath la (valueType la) (valueType i) []) (valueType la) la + AtomicCmpXchgInst { atomicCmpXchgPointer = p + , atomicCmpXchgNewValue = nv + } -> + return $! addDeref $ go (AccessPath p (valueType p) (valueType nv) []) (valueType p) p + AtomicRMWInst { atomicRMWPointer = p + , atomicRMWValue = v + } -> + return $! addDeref $ go (AccessPath p (valueType p) (valueType v) []) (valueType p) p + GetElementPtrInst {} -> + -- FIXME: Should this really get a deref tag? Unclear... + return $! addDeref $ go (AccessPath (toValue i) (valueType i) (valueType i) []) (valueType i) (toValue i) + -- If this is an argument to a function call, it could be a + -- bitcasted GEP or Load + BitcastInst { castedValue = (valueContent' -> InstructionC i') } -> + accessPath i' + _ -> F.failure (NotMemoryInstruction i) + where + addDeref p = + let t = accessPathBaseType p + cs' = (t, AccessDeref) : accessPathTaggedComponents p + in p { accessPathTaggedComponents = cs' } + go p vt v = + -- Note that @go@ does not need to update the accessPathBaseType + -- until the end (fallthrough) case. + case valueContent v of + -- Unions have no representation in the IR; the only way we + -- can identify a union is by looking for instances where a + -- struct pointer type beginning with '%union.' is being cast + -- into something else. This lets us know the union variant + -- being accessed. + InstructionC BitcastInst { castedValue = cv } + | isUnionPointerType (valueType cv) -> + let p' = p { accessPathTaggedComponents = + (valueType v, AccessUnion) : accessPathTaggedComponents p + } + in go p' (valueType v) cv + | otherwise -> go p (valueType v) cv + ConstantC ConstantValue { constantInstruction = BitcastInst { castedValue = cv } } -> + go p (valueType v) cv + InstructionC GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = [_] + } -> + let p' = p { accessPathBaseValue = base + , accessPathTaggedComponents = (valueType v, AccessArray) : accessPathTaggedComponents p + } + in go p' (valueType base) base + InstructionC GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = ixs + } -> + let p' = p { accessPathBaseValue = base + , accessPathTaggedComponents = + gepIndexFold base ixs ++ accessPathTaggedComponents p + } + in go p' (valueType base) base + ConstantC ConstantValue { constantInstruction = + GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = ixs + } } -> + let p' = p { accessPathBaseValue = base + , accessPathTaggedComponents = + gepIndexFold base ixs ++ accessPathTaggedComponents p + } + in go p' (valueType base) base + InstructionC LoadInst { loadAddress = la } -> + let p' = p { accessPathBaseValue = la + , accessPathTaggedComponents = + (vt, AccessDeref) : accessPathTaggedComponents p + } + in go p' (valueType la) la + _ -> p { accessPathBaseValue = v + , accessPathBaseType = vt + } + +isUnionPointerType :: Type -> Bool +isUnionPointerType t = + case t of + TypePointer (TypeStruct (Right name) _ _) _ -> + T.isPrefixOf (T.pack "union.") name + _ -> False + +-- | Convert an 'AbstractAccessPath' to a format that can be written +-- to disk and read back into another process. The format is the pair +-- of the base name of the structure field being accessed (with +-- struct. stripped off) and with any numeric suffixes (which are +-- added by llvm) chopped off. The actually list of 'AccessType's is +-- preserved. +-- +-- The struct name mangling here basically assumes that the types +-- exposed via the access path abstraction have the same definition in +-- all compilation units. Ensuring this between runs is basically +-- impossible, but it is pretty much always the case. +externalizeAccessPath :: (Failure AccessPathError m) + => AbstractAccessPath + -> m (String, [AccessType]) +externalizeAccessPath accPath = + maybe (F.failure (CannotExternalizeType bt)) return $ do + baseName <- structTypeToName (stripPointerTypes bt) + return (baseName, abstractAccessPathComponents accPath) + where + bt = abstractAccessPathBaseType accPath + +-- Internal Helpers + + +derefPointerType :: Type -> Type +derefPointerType (TypePointer p _) = p +derefPointerType t = error ("LLVM.Analysis.AccessPath.derefPointerType: Type is not a pointer type: " ++ show t) + +gepIndexFold :: Value -> [Value] -> [(Type, AccessType)] +gepIndexFold base (ptrIx : ixs) = + -- GEPs always have a pointer as the base operand + let ty@(TypePointer baseType _) = valueType base + in case valueContent ptrIx of + ConstantC ConstantInt { constantIntValue = 0 } -> + snd $ L.foldl' walkGep (baseType, []) ixs + _ -> + snd $ L.foldl' walkGep (baseType, [(ty, AccessArray)]) ixs + where + walkGep (ty, acc) ix = + case ty of + -- If the current type is a pointer, this must be an array + -- access; that said, this wouldn't even be allowed because a + -- pointer would have to go through a Load... check this + TypePointer ty' _ -> (ty', (ty, AccessArray) : acc) + TypeArray _ ty' -> (ty', (ty, AccessArray) : acc) + TypeStruct _ ts _ -> + case valueContent ix of + ConstantC ConstantInt { constantIntValue = fldNo } -> + let fieldNumber = fromIntegral fldNo + ty' = ts !! fieldNumber + in (ty', (ty', AccessField fieldNumber) : acc) + _ -> error ("LLVM.Analysis.AccessPath.gepIndexFold.walkGep: Invalid non-constant GEP index for struct: " ++ show ty) + _ -> error ("LLVM.Analysis.AccessPath.gepIndexFold.walkGep: Unexpected type in GEP: " ++ show ty) +gepIndexFold v [] = + error ("LLVM.Analysis.AccessPath.gepIndexFold: GEP instruction/base with empty index list: " ++ show v) + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/src/LLVM/Analysis/BlockReturnValue.hs b/src/LLVM/Analysis/BlockReturnValue.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/BlockReturnValue.hs @@ -0,0 +1,157 @@ +-- | Label each BasicBlock with the value it *must* return. +-- +-- Most frontends that generate bitcode unify all of the return +-- statements of a function and return a phi node that has a return +-- value for each branch. This pass ('labelBlockReturns') pushes +-- those returns backwards through the control flow graph as labels on +-- basic blocks. The function 'blockReturn' gives the return value +-- for a block, if there is a value that must be returned by that +-- block. +-- +-- The algorithm starts from the return instruction. Non-phi values +-- are propagated backwards to all reachable blocks. Phi values are +-- split and the algorithm propagates each phi incoming value back to +-- the block it came from. A value can be propagated from a block BB +-- to its predecessor block PB if (and only if) BB postdominates PB. +-- Intuitively, the algorithm propagates a return value to a +-- predecessor block if that predecessor block *must* return that +-- value (hence postdominance). +module LLVM.Analysis.BlockReturnValue ( + BlockReturns, + HasBlockReturns(..), + labelBlockReturns, + blockReturn, + blockReturns, + instructionReturn, + instructionReturns + ) where + +import Control.Arrow ( second ) +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as HM +import Data.HashSet ( HashSet ) +import qualified Data.HashSet as HS +import Data.Maybe ( mapMaybe ) +import Data.Monoid + +import LLVM.Analysis +import LLVM.Analysis.CFG + +import LLVM.Analysis.Dominance + +data BlockReturns = BlockReturns (HashMap BasicBlock Value) (HashMap BasicBlock (HashSet Value)) (HashSet BasicBlock) + +class HasBlockReturns a where + getBlockReturns :: a -> BlockReturns + +instance HasBlockReturns BlockReturns where + getBlockReturns = id + +instance Show BlockReturns where + show (BlockReturns _ m _) = unlines $ map showPair (HM.toList m) + where + showPair (bb, vs) = show (basicBlockName bb) ++ ": " ++ show vs + +instance Monoid BlockReturns where + mempty = BlockReturns mempty mempty mempty + mappend (BlockReturns b1 bs1 p1) (BlockReturns b2 bs2 p2) = + BlockReturns (b1 `mappend` b2) (HM.unionWith HS.union bs1 bs2) (HS.union p1 p2) + +-- | Retrieve the Value that must be returned (if any) if the given +-- BasicBlock executes. +blockReturn :: (HasBlockReturns brs) => brs -> BasicBlock -> Maybe Value +blockReturn brs bb = HM.lookup bb m + where + BlockReturns m _ _ = getBlockReturns brs + +-- | Builds on the results from 'blockReturn' and reports *all* of the +-- values that each block can return (results may not include the +-- final block). +blockReturns :: (HasBlockReturns brs) => brs -> BasicBlock -> Maybe [Value] +blockReturns brs bb + | HS.member bb p = Nothing + | otherwise = return $ maybe [] HS.toList (HM.lookup bb m) + where + BlockReturns _ m p = getBlockReturns brs + +-- | Return the Value that must be returned (if any) if the given +-- Instruction is executed. +instructionReturn :: (HasBlockReturns brs) => brs -> Instruction -> Maybe Value +instructionReturn brs i = do + bb <- instructionBasicBlock i + blockReturn (getBlockReturns brs) bb + +instructionReturns :: (HasBlockReturns brs) => brs -> Instruction -> Maybe [Value] +instructionReturns brs i = blockReturns (getBlockReturns brs) bb + where + Just bb = instructionBasicBlock i + +-- | Label each BasicBlock with the value that it must return (if +-- any). +labelBlockReturns :: (HasFunction funcLike, HasPostdomTree funcLike, HasCFG funcLike) + => funcLike -> BlockReturns +labelBlockReturns funcLike = + case functionExitInstructions f of + [] -> BlockReturns mempty mempty mempty + exitInsts -> + let s0 = (mempty, mempty, mempty) + (singleBlockRets, poisonedBlocks, _) = foldr pushReturnValues s0 exitInsts + -- Traverse the list of basic blocks in reverse order + -- (bottom up) to accumulate as many returns as is + -- reasonable. + cs0 = fmap HS.singleton singleBlockRets -- convert to list values + compositeRets = foldr accumulateSuccReturns cs0 (reverse blocks) + in BlockReturns singleBlockRets compositeRets poisonedBlocks + where + f = getFunction funcLike + pdt = getPostdomTree funcLike + cfg = getCFG funcLike + blocks = functionBody f + + pushReturnValues exitInst (m, pois, vis) = + let Just b0 = instructionBasicBlock exitInst + in case exitInst of + RetInst { retInstValue = Just rv } -> + pushReturnUp Nothing (rv, b0) (m, pois, vis) + _ -> (m, pois, vis) + pushReturnUp prevBlock (val, bb) acc@(m, pois, vis) + | HS.member bb vis = acc + | not (prevTerminatorPostdominates pdt prevBlock bb) = + (m, HS.insert bb pois, HS.insert bb vis) + | otherwise = + case valueContent' val of + InstructionC PhiNode { phiIncomingValues = ivs } -> + let vis' = HS.insert bb vis + in foldr (pushReturnUp (Just bb) . second toBB) (m, pois, vis') ivs + _ -> + let m' = HM.insert bb val m + vis' = HS.insert bb vis + preds = basicBlockPredecessors cfg bb + in foldr (pushReturnUp (Just bb)) (m', pois, vis') (zip (repeat val) preds) + + accumulateSuccReturns b acc = + let succs = basicBlockSuccessors cfg b + succRets = mapMaybe (\s -> HM.lookup s acc) succs + in case null succRets of + True -> acc + False -> HM.insert b (mconcat succRets) acc + +-- | Return True if the terminator instruction of the previous block +-- in the traversal postdominates the terminator instruction of the +-- current block. +prevTerminatorPostdominates :: PostdominatorTree -> Maybe BasicBlock -> BasicBlock -> Bool +prevTerminatorPostdominates _ Nothing _ = True +prevTerminatorPostdominates pdt (Just prevBlock) bb = + postdominates pdt prevTerm bbTerm + where + prevTerm = basicBlockTerminatorInstruction prevBlock + bbTerm = basicBlockTerminatorInstruction bb + +-- | Unconditionally convert a Value to a BasicBlock. This should +-- always work for the second value of each Phi incoming value. There +-- may be some cases with blockaddresses that fail... +toBB :: Value -> BasicBlock +toBB v = + case valueContent v of + BasicBlockC bb -> bb + _ -> error "LLVM.Analysis.BlockReturnValue.toBB: not a basic block" diff --git a/src/LLVM/Analysis/CDG.hs b/src/LLVM/Analysis/CDG.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CDG.hs @@ -0,0 +1,241 @@ +-- | Control Dependence Graphs for the LLVM IR +-- +-- This module follows the definition of control dependence of Cytron et al +-- (http://dl.acm.org/citation.cfm?doid=115372.115320): +-- +-- Let X and Y be nodes in the CFG. If X appears on every path from Y +-- to Exit, then X postdominates Y. If X postdominates Y but X != Y, +-- then X strictly postdominates Y. +-- +-- A CFG node Y is control dependent on a CFG node X if both: +-- +-- * There is a non-null path p from X->Y such that Y postdominates +-- every node *after* X on p. +-- +-- * The node Y does not strictly postdominate the node X. +-- +-- This CDG formulation does not insert a dummy Start node to link +-- together all of the top-level nodes. This just means that the set +-- of control dependencies can be empty if code will be executed +-- unconditionally. +module LLVM.Analysis.CDG ( + -- * Types + CDG, + HasCDG(..), + -- * Constructor + controlDependenceGraph, + -- * Queries + directControlDependencies, + controlDependencies, + ) where + +import Control.Arrow ( (&&&) ) +import qualified Data.Foldable as F +import Data.GraphViz +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Monoid +import Data.Set ( Set ) +import qualified Data.Set as S + +import LLVM.Analysis +import LLVM.Analysis.CFG +import LLVM.Analysis.Dominance + +class HasCDG a where + getCDG :: a -> CDG + +instance HasCDG CDG where + getCDG = id + +-- | Warning, this is an expensive instance to invoke as it constructs +-- the CDG. +instance HasCDG PostdominatorTree where + getCDG = controlDependenceGraph + +instance HasPostdomTree CDG where + getPostdomTree (CDG pdt _) = pdt + +instance HasCFG CDG where + getCFG = getCFG . getPostdomTree + +instance HasFunction CDG where + getFunction = getFunction . getCFG + +data CDG = CDG PostdominatorTree (Map BasicBlock [BasicBlock]) + +{- Note [CDG Format] + +The CDG is a mapping BasicBlocks to the other BasicBlocks that they +are /directly/ control dependent on. + +-} + +-- | Construct the control dependence graph for a function (from its +-- CFG). This follows the construction from chapter 9 of the +-- Munchnick Compiler Design and Implementation book. +-- +-- For an input function F: +-- +-- 1) Construct the CFG G for F +-- +-- 2) Construct the postdominator tree PT for F +-- +-- 3) Let S be the set of edges m->n in G such that n does not +-- postdominate m +-- +-- 4) For each edge m->n in S, find the lowest common ancestor l of m +-- and n in the postdominator tree. All nodes on the path from +-- l->n (not including l) in PT are control dependent on m. If +-- there is no common ancestor (disconnected PDT because of +-- multiple exit nodes), the lowest common ancestor is then the +-- virtual exit node, so /all/ of the postdominators of n are +-- control dependent on m. +-- +-- Note: the typical construction augments the CFG with a fake start +-- node. Doing that here would be a bit complicated, so the graph +-- just isn't connected by a fake Start node. +controlDependenceGraph :: (HasCFG f, HasPostdomTree f) => f -> CDG +controlDependenceGraph flike = + CDG pdt $ fmap S.toList $ foldr addPairs mempty (functionBody f) + where + cfg = getCFG flike + f = getFunction cfg + pdoms = M.fromList $ postdominators pdt + pdt = getPostdomTree flike + addPairs bM acc = + foldr (addCDGEdge pdt pdoms bM) acc (basicBlockSuccessors cfg bM) + + +-- | Get the list of instructions that an instruction is control +-- dependent upon. As noted above, the list will be empty if the +-- instruction is executed unconditionally. +controlDependencies :: (HasCDG cdg) => cdg -> Instruction -> [Instruction] +controlDependencies cdgLike i = + go mempty (S.fromList directDeps) directDeps + where + cdg = getCDG cdgLike + directDeps = directControlDependencies cdg i + + go _ acc [] = S.toList acc + go visited acc (cdep:rest) + | S.member cdep visited = go visited acc rest + | otherwise = + let newDeps = directControlDependencies cdg cdep + rest' = rest ++ newDeps + in go (S.insert cdep visited) (S.union acc (S.fromList newDeps)) rest' + +-- | Get the list of instructions that an instruction is directly +-- control dependent upon (direct parents in the CDG). +directControlDependencies :: (HasCDG cdg) => cdg -> Instruction -> [Instruction] +directControlDependencies cdgLike i = + maybe [] (map basicBlockTerminatorInstruction) (M.lookup bb m) + where + CDG _ m = getCDG cdgLike + Just bb = instructionBasicBlock i + +-- Implementation + + +-- | For each block M and each successor of M, N, add (M,N) if the +-- first instruction of N does not postdominate the terminator +-- instruction of M. +addCDGEdge :: PostdominatorTree -- ^ The postdominator tree + -> Map Instruction [Instruction] -- ^ The entire postdom relation + -> BasicBlock -- ^ M + -> BasicBlock -- ^ N + -> Map BasicBlock (Set BasicBlock) + -> Map BasicBlock (Set BasicBlock) +addCDGEdge pdt pdoms bM bN acc + -- If it is a postdominator, this is not an edge in S + | postdominates pdt nEntry mTerm = acc + -- Otherwise it is and we need to find a common ancestor in the + -- PDT + | otherwise = case commonAncestor mpdoms npdoms of + Just l -> + let cdepsOnM = bN : postdomBlocks (filter (/=l) npdoms) + in foldr addControlDep acc cdepsOnM + -- If there is no common ancestor, then all of the + -- postdominators of n are control dependent on m. + Nothing -> + let deps = bN : postdomBlocks npdoms + in foldr addControlDep acc deps + where + addControlDep b = M.insertWith S.union b (S.singleton bM) + mTerm = basicBlockTerminatorInstruction bM + nEntry : _ = basicBlockInstructions bN + -- These lookups should never fail (unless the caller provided + -- the postdominator tree for a different function). the + -- postdominators function just returns empty sets, and the + -- function handles /every/ instruction in the input function. + Just mpdoms = M.lookup mTerm pdoms + Just npdoms = M.lookup nEntry pdoms + +-- | Convert a list of Instructions into the list of their +-- BasicBlocks. There are no repetitions in the result. +postdomBlocks :: [Instruction] -> [BasicBlock] +postdomBlocks = S.toList . foldr addInstBlock mempty + where + addInstBlock i acc = + let Just bb = instructionBasicBlock i + in S.insert bb acc + +-- | Given two lists, find the first element they share in common (if +-- any). +commonAncestor :: [Instruction] -> [Instruction] -> Maybe Instruction +commonAncestor l1 = F.find (`elem` l1) + +{- Note [CDG] + +We can compute the CDG based on just the blocks in the graph. All of +the instructions in a given basic block are always at the same level +in the CDG and depend on the same control decisions as the first +instruction in the block. + +We also only need to store the blocks, since any instruction looked up +has a back-pointer to its block, which will let us look it up in the +CDG. + +Start by finding the set S, where we just consider connected +BasicBlocks. + +-} + + + +-- Visualization + +instance ToGraphviz CDG where + toGraphviz = cdgGraphvizRepr + +cdgGraphvizParams :: GraphvizParams n Instruction el BasicBlock Instruction +cdgGraphvizParams = + defaultParams { fmtNode = \(_,l) -> [ toLabel (toValue l) ] + , clusterID = Int . basicBlockUniqueId + , clusterBy = nodeCluster + , fmtCluster = formatCluster + } + where + nodeCluster l@(_, i) = + let Just bb = instructionBasicBlock i + in C bb (N l) + formatCluster bb = [GraphAttrs [toLabel (show (basicBlockName bb))]] + +cdgGraphvizRepr :: CDG -> DotGraph Int +cdgGraphvizRepr cdg@(CDG _ bm) = graphElemsToDot cdgGraphvizParams ns es + where + f = getFunction cdg + ns = map (instructionUniqueId &&& id) (functionInstructions f) + es = concatMap blockEdges (functionBody f) + + blockEdges bb = + case M.lookup bb bm of + Nothing -> [] + Just deps -> + -- Each instruction in BB gets an edge to the terminator + -- of each dependency + let depTerms = map basicBlockTerminatorInstruction deps + in concatMap (addEdges depTerms) (basicBlockInstructions bb) + addEdges depTerms i = map (addEdge i) depTerms + addEdge i dterm = + (instructionUniqueId i, instructionUniqueId dterm, ()) diff --git a/src/LLVM/Analysis/CFG.hs b/src/LLVM/Analysis/CFG.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CFG.hs @@ -0,0 +1,13 @@ +-- | This module defines control flow graphs over the LLVM IR. +module LLVM.Analysis.CFG ( + -- * Types + CFG, + HasCFG(..), + -- * Constructors + controlFlowGraph, + -- * Accessors + basicBlockPredecessors, + basicBlockSuccessors + ) where + +import LLVM.Analysis.CFG.Internal diff --git a/src/LLVM/Analysis/CFG/Internal.hs b/src/LLVM/Analysis/CFG/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CFG/Internal.hs @@ -0,0 +1,794 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ExistentialQuantification, GADTs #-} +{-# LANGUAGE ViewPatterns, ScopedTypeVariables, PatternGuards #-} +module LLVM.Analysis.CFG.Internal ( + -- * CFG + CFG(..), + HasCFG(..), + controlFlowGraph, + basicBlockPredecessors, + basicBlockSuccessors, + -- * Dataflow + DataflowAnalysis(..), + fwdDataflowAnalysis, + bwdDataflowAnalysis, + fwdDataflowEdgeAnalysis, + bwdDataflowEdgeAnalysis, + dataflow, + DataflowResult(..), + dataflowResult, + dataflowResultAt, + -- * Internal types + Insn(..), + ) where + +import Compiler.Hoopl +import Control.DeepSeq +import Control.Monad ( (>=>), (<=<) ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict +import Data.Function ( on ) +import qualified Data.GraphViz as GV +import qualified Data.List as L +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Monoid +import Data.Set ( Set ) +import qualified Data.Set as S +import Data.Tuple ( swap ) +import qualified Text.PrettyPrint.GenericPretty as PP + +import LLVM.Analysis + +-- CFG stuff + +-- | A class for things from which a CFG can be obtained. +class HasCFG a where + getCFG :: a -> CFG + +instance HasCFG CFG where + getCFG = id + +instance HasCFG Function where + getCFG = controlFlowGraph + +instance HasFunction CFG where + getFunction = cfgFunction + +instance FuncLike CFG where + fromFunction = controlFlowGraph + +-- | The type of function control flow graphs. +data CFG = CFG { cfgFunction :: Function + , cfgLabelMap :: Map BasicBlock Label + , cfgBlockMap :: Map Label BasicBlock + , cfgBody :: Graph Insn C C + , cfgEntryLabel :: Label + , cfgExitLabel :: Label + , cfgPredecessors :: Map BasicBlock [BasicBlock] + } +-- See Note [CFG Back Edges] + +{- Note [CFG Back Edges] + +The control flow graph provided by hoopl only tracks forward edges. +Since we want to let users query predecessor blocks, we need to record +predecessors on the side at CFG construction time (see +cfgPredecessors). + +We build the cache with a single pass over the successors of the CFG. + +-} + +-- | This instance does not compare the graphs directly - instead it +-- compares just the function from which the graph is constructed. +-- The construction is completely deterministic so this should be +-- fine. It is also fast because function comparison just compares +-- unique integer IDs. +instance Eq CFG where + (==) = on (==) cfgFunction + +-- | This is a wrapper GADT around the LLVM IR to mesh with Hoopl. It +-- won't be exported or exposed to the user at all. We need this for +-- two reasons: +-- +-- 1) Hoopl requires explicit Label instructions. In LLVM these are +-- implicit in the function structure through BasicBlocks +-- +-- 2) Additionally, LLVM doens't have a unique exit instruction per +-- function. resume, ret, and unreachable all terminate execution. +-- c.f. UniqueExitLabel and ExitLabel (both seem to be needed because +-- hoopl blocks need an entry and an exit). +data Insn e x where + Lbl :: BasicBlock -> Label -> Insn C O + Terminator :: Instruction -> [Label] -> Insn O C + UniqueExitLabel :: Label -> Insn C O + UniqueExit :: Insn O C + Normal :: Instruction -> Insn O O + +instance NonLocal Insn where + entryLabel (Lbl _ lbl) = lbl + entryLabel (UniqueExitLabel lbl) = lbl + successors (Terminator _ lbls) = lbls + successors UniqueExit = [] + +instance Show (Insn e x) where + show (Lbl bb _) = identifierAsString (basicBlockName bb) ++ ":" + show (Terminator t _) = " " ++ show t + show (Normal i) = " " ++ show i + show (UniqueExitLabel _) = "UniqueExit:" + show UniqueExit = " done" + +-- | Create a CFG for a function +controlFlowGraph :: Function -> CFG +controlFlowGraph f = runSimpleUniqueMonad (evalStateT builder mempty) + where + builder = do + -- This is a unique label not associated with any block. All of + -- the instructions that exit a function get an edge to this + -- virtual label. + exitLabel <- lift $ freshLabel + gs <- mapM (fromBlock exitLabel) (functionBody f) + let g = L.foldl' (|*><*|) emptyClosedGraph gs + x = mkFirst (UniqueExitLabel exitLabel) <*> mkLast UniqueExit + g' = g |*><*| x + m <- get + let i0 = functionEntryInstruction f + Just bb0 = instructionBasicBlock i0 + Just fEntryLabel = M.lookup bb0 m + cfg = CFG { cfgFunction = f + , cfgBody = g' + , cfgLabelMap = m + , cfgBlockMap = M.fromList $ map swap $ M.toList m + , cfgEntryLabel = fEntryLabel + , cfgExitLabel = exitLabel + , cfgPredecessors = mempty + } + preds = foldr (recordPreds cfg) mempty (functionBody f) + return $ cfg { cfgPredecessors = fmap S.toList preds } + addPred pblock b = + M.insertWith S.union b (S.singleton pblock) + recordPreds cfg bb acc = + let succs = basicBlockSuccessors cfg bb + in foldr (addPred bb) acc succs + +-- | A builder environment for constructing CFGs. Mostly needed for +-- generating and tracking block labels. +type Builder a = StateT (Map BasicBlock Label) SimpleUniqueMonad a + +-- | Return the Label for the given BasicBlock. Generates a new Label +-- and caches it, if necessary. +blockLabel :: BasicBlock -> Builder Label +blockLabel bb = do + m <- get + case M.lookup bb m of + Just l -> return l + Nothing -> do + l <- lift $ freshLabel + put $ M.insert bb l m + return l + +-- | Convert a BasicBlock into a CFG chunk (the caller will combine +-- all of the chunks). The block is C C shaped. The first argument +-- is the unique exit label that certain instructions generated edges +-- to. +fromBlock :: Label -> BasicBlock -> Builder (Graph Insn C C) +fromBlock xlabel bb = do + lbl <- blockLabel bb + let body = basicBlockInstructions bb + (body', [term]) = L.splitAt (length body - 1) body + normalNodes = map Normal body' + tlbls <- terminatorLabels xlabel term + let termNode = Terminator term tlbls + entry = Lbl bb lbl + return $ mkFirst entry <*> mkMiddles normalNodes <*> mkLast termNode + +-- | All instructions that exit a function get an edge to the special +-- ExitLabel. This allows all results along all branches (even those +-- with non-standard exits) to be collected. If only normal exit +-- results are desired, just check the dataflow result for RetInst +-- results. +terminatorLabels :: Label -> Instruction -> Builder [Label] +terminatorLabels xlabel i = + case i of + RetInst {} -> return [xlabel] + UnconditionalBranchInst { unconditionalBranchTarget = t } -> do + bl <- blockLabel t + return [bl] + BranchInst { branchTrueTarget = tt, branchFalseTarget = ft } -> do + tl <- blockLabel tt + fl <- blockLabel ft + return [tl, fl] + SwitchInst { switchDefaultTarget = dt, switchCases = (map snd -> ts) } -> do + dl <- blockLabel dt + tls <- mapM blockLabel ts + return $ dl : tls + IndirectBranchInst { indirectBranchTargets = ts } -> + mapM blockLabel ts + ResumeInst {} -> return [xlabel] + UnreachableInst {} -> return [xlabel] + InvokeInst { invokeNormalLabel = nt, invokeUnwindLabel = ut } -> do + nl <- blockLabel nt + ul <- blockLabel ut + return [nl, ul] + _ -> error "LLVM.Analysis.CFG.successors: non-terminator instruction" + +basicBlockPredecessors :: (HasCFG cfgLike) => cfgLike -> BasicBlock -> [BasicBlock] +basicBlockPredecessors cfgLike bb = + fromMaybe [] $ M.lookup bb (cfgPredecessors cfg) + where + cfg = getCFG cfgLike + +basicBlockSuccessors :: (HasCFG cfgLike) => cfgLike -> BasicBlock -> [BasicBlock] +basicBlockSuccessors cfgLike bb = case cfgBody cfg of + GMany _ lm _ -> fromMaybe [] $ do + blbl <- basicBlockToLabel cfg bb + blk <- mapLookup blbl lm + return $ mapMaybe (labelToBasicBlock cfg) (successors blk) + where + cfg = getCFG cfgLike + +basicBlockToLabel :: CFG -> BasicBlock -> Maybe Label +basicBlockToLabel cfg bb = M.lookup bb (cfgLabelMap cfg) + +labelToBasicBlock :: CFG -> Label -> Maybe BasicBlock +labelToBasicBlock cfg l = M.lookup l (cfgBlockMap cfg) + + +-- Visualization + +cfgGraphvizParams :: GV.GraphvizParams n Instruction CFGEdge BasicBlock Instruction +cfgGraphvizParams = + GV.defaultParams { GV.fmtNode = \(_,l) -> [GV.toLabel (toValue l)] + , GV.fmtEdge = formatEdge + , GV.clusterID = GV.Int . basicBlockUniqueId + , GV.fmtCluster = formatCluster + , GV.clusterBy = nodeCluster + } + where + nodeCluster l@(_, i) = + let Just bb = instructionBasicBlock i + in GV.C bb (GV.N l) + formatCluster bb = [GV.GraphAttrs [GV.toLabel (show (basicBlockName bb))]] + formatEdge (_, _, l) = + let lbl = GV.toLabel l + in case l of + TrueEdge -> [lbl, GV.color GV.ForestGreen] + FalseEdge -> [lbl, GV.color GV.Crimson] + EqualityEdge _ -> [lbl, GV.color GV.DeepSkyBlue] + IndirectEdge -> [lbl, GV.color GV.Indigo, GV.style GV.dashed] + UnwindEdge -> [lbl, GV.color GV.Tomato4, GV.style GV.dotted] + OtherEdge -> [lbl] + +data CFGEdge = TrueEdge + | FalseEdge + | EqualityEdge Value + | IndirectEdge + | UnwindEdge + | OtherEdge + deriving (Eq, Show) + +instance GV.Labellable CFGEdge where + toLabelValue TrueEdge = GV.toLabelValue "True" + toLabelValue FalseEdge = GV.toLabelValue "False" + toLabelValue (EqualityEdge v) = GV.toLabelValue ("== " ++ show v) + toLabelValue IndirectEdge = GV.toLabelValue "Indirect" + toLabelValue UnwindEdge = GV.toLabelValue "Unwind" + toLabelValue OtherEdge = GV.toLabelValue "" + +instance ToGraphviz CFG where + toGraphviz = cfgGraphvizRepr + +cfgGraphvizRepr :: CFG -> GV.DotGraph Int +cfgGraphvizRepr cfg = GV.graphElemsToDot cfgGraphvizParams ns es + where + f = getFunction cfg + ns = map toGNode (functionInstructions f) + es = concatMap toEdges (functionBody f) + +-- | There is an edge from the terminator of the BB to the entry of +-- each of its successors. The edges should be labelled according to +-- the type of the terminator. There are OtherEdge markers on between +-- each instruction in the BB. +toEdges :: BasicBlock -> [(Int, Int, CFGEdge)] +toEdges bb = + case ti of + RetInst {} -> intraEdges + UnreachableInst {} -> intraEdges + UnconditionalBranchInst { unconditionalBranchTarget = t } -> + let (ei:_) = basicBlockInstructions t + in (instructionUniqueId ti, instructionUniqueId ei, OtherEdge) : intraEdges + BranchInst { branchTrueTarget = tt, branchFalseTarget = ft } -> + let (tei:_) = basicBlockInstructions tt + (fei:_) = basicBlockInstructions ft + in (instructionUniqueId ti, instructionUniqueId tei, TrueEdge) : + (instructionUniqueId ti, instructionUniqueId fei, FalseEdge) : + intraEdges + SwitchInst { switchDefaultTarget = dt, switchCases = cases } -> + let (dei:_) = basicBlockInstructions dt + caseNodes = map toCaseNode cases + in (instructionUniqueId ti, instructionUniqueId dei, OtherEdge):caseNodes ++ intraEdges + IndirectBranchInst { indirectBranchTargets = bs } -> + map toIndirectEdge bs ++ intraEdges + ResumeInst {} -> intraEdges + InvokeInst { invokeUnwindLabel = ul, invokeNormalLabel = nl } -> + let (nei:_) = basicBlockInstructions nl + (uei:_) = basicBlockInstructions ul + in (instructionUniqueId ti, instructionUniqueId nei, OtherEdge): + (instructionUniqueId ti, instructionUniqueId uei, UnwindEdge): + intraEdges + _ -> error "Not a terminator instruction" + where + -- Basic blocks are not allowed to be empty so this pattern match + -- should never fail. + is@(_:rest) = basicBlockInstructions bb + intraEdges = map toIntraEdge (zip is rest) + toIntraEdge (s,d) = (instructionUniqueId s, instructionUniqueId d, OtherEdge) + ti = basicBlockTerminatorInstruction bb + + toIndirectEdge tgt = + let (ei:_) = basicBlockInstructions tgt + in (instructionUniqueId ti, instructionUniqueId ei, IndirectEdge) + + toCaseNode (val, tgt) = + let (ei:_) = basicBlockInstructions tgt + in (instructionUniqueId ti, instructionUniqueId ei, EqualityEdge val) + +toGNode :: Instruction -> (Int, Instruction) +toGNode i = (instructionUniqueId i, i) + + +-- Dataflow analysis stuff + +-- | An opaque representation of a dataflow analysis. Analyses of +-- this type are suitable for both forward and backward use. +-- +-- For all dataflow analyses, the standard rules apply. +-- +-- 1) @meet a top == a@ +-- +-- 2) Your lattice @f@ must have finite height +-- +-- The @m@ type parameter is a 'Monad'; this dataflow framework +-- provides a /monadic/ transfer function. This is intended to allow +-- transfer functions to have monadic contexts that provide +-- MonadReader and MonadWriter-like functionality. State is also +-- useful for caching expensive sub-computations. Keep in mind that +-- the analysis iterates to a fixedpoint and side effects in the monad +-- will be repeated. +data DataflowAnalysis m f where + FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f + , analysisMeet :: f -> f -> f + , analysisTransfer :: f -> Instruction -> m f + , analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)]) + } -> DataflowAnalysis m f + BwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f + , analysisMeet :: f -> f -> f + , analysisTransfer :: f -> Instruction -> m f + , analysisBwdEdgeTransfer :: Maybe ([(BasicBlock, f)] -> Instruction -> m f) + } -> DataflowAnalysis m f + +-- | Define a basic 'DataflowAnalysis' +fwdDataflowAnalysis :: (Eq f, Monad m) + => f -- ^ Top + -> (f -> f -> f) -- ^ Meet + -> (f -> Instruction -> m f) -- ^ Transfer + -> DataflowAnalysis m f +fwdDataflowAnalysis top m t = FwdDataflowAnalysis top m t Nothing + +-- | A basic backward dataflow analysis +bwdDataflowAnalysis :: (Eq f, Monad m) + => f -- ^ Top + -> (f -> f -> f) -- ^ Meet + -> (f -> Instruction -> m f) -- ^ Transfer + -> DataflowAnalysis m f +bwdDataflowAnalysis top m t = BwdDataflowAnalysis top m t Nothing + +-- | A forward dataflow analysis that provides an addition /edge +-- transfer function/. This function is run with each Terminator +-- instruction (/after/ the normal transfer function, whose results +-- are fed to the edge transfer function). The edge transfer function +-- allows you to let different information flow to each successor +-- block of a terminator instruction. +-- +-- If a BasicBlock in the edge transfer result is not a successor of +-- the input instruction, that mapping is discarded. Multiples are +-- @meet@ed together. Missing values are taken from the result of the +-- normal transfer function. +fwdDataflowEdgeAnalysis :: (Eq f, Monad m) + => f -- ^ Top + -> (f -> f -> f) -- ^ meet + -> (f -> Instruction -> m f) -- ^ Transfer + -> (f -> Instruction -> m [(BasicBlock, f)]) -- ^ Edge Transfer + -> DataflowAnalysis m f +fwdDataflowEdgeAnalysis top m t e = + FwdDataflowAnalysis top m t (Just e) + +bwdDataflowEdgeAnalysis :: (Eq f, Monad m) + => f -- ^ Top + -> (f -> f -> f) -- ^ meet + -> (f -> Instruction -> m f) -- ^ Transfer + -> ([(BasicBlock, f)] -> Instruction -> m f) -- ^ Edge Transfer + -> DataflowAnalysis m f +bwdDataflowEdgeAnalysis top m t e = + BwdDataflowAnalysis top m t (Just e) + + + +-- | The opaque result of a dataflow analysis. Use the functions +-- 'dataflowResult' and 'dataflowResultAt' to extract results. +data DataflowResult m f where + DataflowResult :: CFG + -> DataflowAnalysis m f + -> Fact C f + -> Direction + -> DataflowResult m f + +-- See Note [Dataflow Results] + +instance (Show f) => Show (DataflowResult m f) where + show (DataflowResult _ _ fb _) = + PP.pretty (map (\(f,s) -> (show f, show s)) (mapToList fb)) + +instance (Eq f) => Eq (DataflowResult m f) where + (DataflowResult c1 _ m1 d1) == (DataflowResult c2 _ m2 d2) = + c1 == c2 && m1 == m2 && d1 == d2 + +-- This may have to cheat... LabelMap doesn't have an NFData instance. +-- Not sure if this will affect monad-par or not. +instance (NFData f) => NFData (DataflowResult m f) where + rnf _ = () -- (DataflowResult m) = m `deepseq` () + +-- | Look up the dataflow fact at a particular Instruction. +dataflowResultAt :: DataflowResult m f + -> Instruction + -> m f +dataflowResultAt (DataflowResult cfg (FwdDataflowAnalysis top meet transfer _) m dir) i = do + let Just bb = instructionBasicBlock i + Just lbl = M.lookup bb (cfgLabelMap cfg) + initialFactAndInsts = findInitialFact bb lbl dir + case initialFactAndInsts of + Nothing -> return top + Just (bres, is) -> replayTransfer is bres + where + findInitialFact bb lbl Fwd = do + f0 <- lookupFact lbl m + return (f0, basicBlockInstructions bb) + -- Here, look up the facts for all successors + findInitialFact bb _ Bwd = + case basicBlockSuccessors cfg bb of + [] -> do + f0 <- lookupFact (cfgExitLabel cfg) m + return (f0, reverse (basicBlockInstructions bb)) + ss -> do + let trBlock b = do + l <- basicBlockToLabel cfg b + lookupFact l m + f0 = foldr meet top (mapMaybe trBlock ss) + return (f0, reverse (basicBlockInstructions bb)) + replayTransfer [] _ = error "LLVM.Analysis.Dataflow.dataflowResult: replayed past end of block, impossible" + replayTransfer (thisI:rest) r + | thisI == i = transfer r i + | otherwise = do + r' <- transfer r thisI + replayTransfer rest r' + + +-- | Look up the dataflow fact at the virtual exit note. This +-- combines the results along /all/ paths, including those ending in +-- "termination" instructions like Unreachable and Resume. +-- +-- If you want the result at only the return instruction(s), use +-- 'dataflowResultAt' and 'meets' the results together. +dataflowResult :: DataflowResult m f -> f +dataflowResult (DataflowResult cfg (FwdDataflowAnalysis top _ _ _) m _) = + fromMaybe top $ lookupFact (cfgExitLabel cfg) m +dataflowResult (DataflowResult cfg (BwdDataflowAnalysis top _ _ _) m _) = + fromMaybe top $ lookupFact (cfgEntryLabel cfg) m + +dataflow :: forall m f cfgLike . (HasCFG cfgLike) + => cfgLike -- ^ Something providing a CFG + -> DataflowAnalysis m f -- ^ The analysis to run + -> f -- ^ Initial fact for the entry node + -> m (DataflowResult m f) +dataflow cfgLike da@FwdDataflowAnalysis { analysisTop = top + , analysisMeet = meet + , analysisTransfer = transfer + , analysisFwdEdgeTransfer = etransfer + } fact0 = do +{- + +-- | Run a forward dataflow analysis +forwardDataflow :: forall m f cfgLike . (HasCFG cfgLike) + => cfgLike -- ^ Something providing a CFG + -> DataflowAnalysis m f -- ^ The analysis to run + -> f -- ^ Initial fact for the entry node + -> m (DataflowResult m f) +forwardDataflow cfgLike da@DataflowAnalysis { analysisTop = top + , analysisMeet = meet + , analysisTransfer = transfer + , analysisFwdEdgeTransfer = etransfer + } fact0 = do +-} + r <- graph (cfgBody cfg) (mapSingleton elbl fact0) + return $ DataflowResult cfg da r Fwd + where + cfg = getCFG cfgLike + elbl = cfgEntryLabel cfg + entryPoints = [elbl] + -- We'll record the entry block in the CFG later + graph :: Graph Insn C C -> Fact C f -> m (Fact C f) + -- graph GNil = return + -- graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) >=> exit x + where + exit :: MaybeO x (Block Insn C O) -> Fact C f -> m (Fact x f) + exit (JustO blk) = arfx block blk + exit NothingO = return + ebcat entry cbdy = c entryPoints entry + where + c :: [Label] -> MaybeO e (Block Insn O C) + -> Fact e f -> m (Fact C f) +-- c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c eps NothingO = body eps cbdy + c _ _ = error "Bogus GADT pattern match failure" + + -- Analyze Rewrite Forward Transformer? + arfx :: forall thing x . (NonLocal thing) + => (thing C x -> f -> m (Fact x f)) + -> (thing C x -> Fact C f -> m (Fact x f)) + arfx arf thing fb = arf thing f' + where + -- We don't do the meet operation here (unlike hoopl). They + -- only performed it (knowing it is a no-op) to preserve side + -- effects. + Just f' = lookupFact (entryLabel thing) fb + + body :: [Label] + -> LabelMap (Block Insn C C) + -> Fact C f + -> m (Fact C f) + body bentries blockmap initFbase = + fixpoint Fwd da doBlock bentries blockmap initFbase + where + doBlock :: forall x . Block Insn C x -> FactBase f -> m (Fact x f) + doBlock b fb = block b entryFact + where + entryFact = fromMaybe top $ lookupFact (entryLabel b) fb + + node :: forall e x . Insn e x -> f -> m (Fact x f) + -- Labels aren't visible to the user and don't add facts for us. + -- Now, the phi variant *can* add facts + node (Lbl _ _) f = return f + node (UniqueExitLabel _) f = return f + -- Standard transfer function + node (Normal i) f = transfer f i + -- This gets a single input fact and needs to produce a + -- *factbase*. This should actually be fairly simple; run the + -- transfer function on the instruction and update all of the lbl + node (Terminator i lbls) f = do + f' <- transfer f i + -- Now create a new map with all of the labels mapped to + -- f'. Code later will handle merging this result. + let baseResult = mapFromList $ zip lbls (repeat f') + case etransfer of + Nothing -> return baseResult + Just etransfer' -> do + -- Now convert BasicBlocks to their labels (discarding + -- mappings where the label is not in @lbls@. Duplicates + -- are meeted together. Missing elements are filled in by + -- the result of the normal transfer function + blockOuts <- etransfer' f' i + let res = foldr (addBlockEdgeResult lbls) mapEmpty blockOuts + return $ mapUnion res (mapDeleteList (mapKeys res) baseResult) + -- The unique exit doesn't do anything - it just collects the + -- final results. + node UniqueExit _ = return mapEmpty + + addBlockEdgeResult :: [Label] -> (BasicBlock, f) -> FactBase f -> FactBase f + addBlockEdgeResult lbls (bb, res) acc + | Just lbl <- basicBlockToLabel cfg bb, lbl `elem` lbls = + case mapLookup lbl acc of + Nothing -> mapInsert lbl res acc + Just ex -> mapInsert lbl (meet res ex) acc + | otherwise = acc + + block :: Block Insn e x -> f -> m (Fact x f) + block BNil = return + block (BlockCO l b) = node l >=> block b + block (BlockCC l b n) = node l >=> block b >=> node n + block (BlockOC b n) = block b >=> node n + block (BMiddle n) = node n + block (BCat b1 b2) = block b1 >=> block b2 + block (BSnoc h n) = block h >=> node n + block (BCons n t) = node n >=> block t +{- +-- | Run a backward dataflow analysis +backwardDataflow :: forall m f cfgLike . (HasCFG cfgLike) + => cfgLike -- ^ Something providing a CFG + -> DataflowAnalysis m f -- ^ The analysis to run + -> f -- ^ Initial fact for the entry node + -> m (DataflowResult m f) +backwardDataflow cfgLike da@DataflowAnalysis { analysisTop = top + , analysisMeet = meet + , analysisTransfer = transfer + } fact0 = do +-} +dataflow cfgLike da@BwdDataflowAnalysis { analysisTop = top + , analysisMeet = meet + , analysisTransfer = transfer + } fact0 = do + r <- graph (cfgBody cfg) (mapSingleton xlbl fact0) + return $ DataflowResult cfg da r Bwd + where + cfg = getCFG cfgLike + xlbl = cfgExitLabel cfg + entryPoints = [xlbl] + -- We'll record the entry block in the CFG later + graph :: Graph Insn C C -> Fact C f -> m (Fact C f) + -- graph GNil = return + -- graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) <=< exit x + where + exit :: MaybeO x (Block Insn C O) -> Fact C f -> m (Fact x f) + exit (JustO blk) = arbx block blk + exit NothingO = return + ebcat entry cbdy = c entryPoints entry + where + c :: [Label] -> MaybeO e (Block Insn O C) + -> Fact e f -> m (Fact C f) +-- c NothingC (JustO entry) = block entry <=< body (successors entry) bdy + c eps NothingO = body eps cbdy + c _ _ = error "Bogus GADT pattern match failure" + + -- Analyze Rewrite Backward Transformer? + arbx :: forall thing x . (NonLocal thing) + => (thing C x -> f -> m (Fact x f)) + -> (thing C x -> Fact C f -> m (Fact x f)) + arbx arf thing fb = arf thing f' + where + -- We don't do the meet operation here (unlike hoopl). They + -- only performed it (knowing it is a no-op) to preserve side + -- effects. + Just f' = lookupFact (entryLabel thing) fb + + body :: [Label] + -> LabelMap (Block Insn C C) + -> Fact C f + -> m (Fact C f) + body bentries blockmap initFbase = + fixpoint Bwd da doBlock (map entryLabel (backwardBlockList bentries blockmap)) blockmap initFbase + where + doBlock :: forall x . Block Insn C x -> Fact x f -> m (LabelMap f) + doBlock b fb = do + f <- block b fb + return $ mapSingleton (entryLabel b) f + + node :: forall e x . Insn e x -> Fact x f -> m f + -- Labels aren't visible to the user and don't add facts for us. + -- Now, the phi variant *can* add facts + node (Lbl _ _) f = return f + node (UniqueExitLabel _) f = return f + -- Standard transfer function + node (Normal i) f = transfer f i + -- In backward mode, the transfer function gets a FactBase and + -- returns a single Fact. + node (Terminator i lbls) fbase = do + let fs = mapMaybe (\l -> lookupFact l fbase) lbls + f = foldr meet top fs + transfer f i + -- The unique exit doesn't do anything - it just collects the + -- final results. + node UniqueExit fbase = + return $ foldr meet top (mapElems fbase) + + block :: Block Insn e x -> Fact x f -> m f + block BNil = return + block (BlockCO l b) = node l <=< block b + block (BlockCC l b n) = node l <=< block b <=< node n + block (BlockOC b n) = block b <=< node n + block (BMiddle n) = node n + block (BCat b1 b2) = block b1 <=< block b2 + block (BSnoc h n) = block h <=< node n + block (BCons n t) = node n <=< block t + +forwardBlockList :: (NonLocal n, LabelsPtr entry) + => entry -> Body n -> [Block n C C] +forwardBlockList entries blks = postorder_dfs_from blks entries + +backwardBlockList :: (NonLocal n, LabelsPtr entries) + => entries -> Body n -> [Block n C C] +backwardBlockList entries body = reverse $ forwardBlockList entries body + +data Direction = Fwd | Bwd + deriving (Eq) + +dataflowMeet :: DataflowAnalysis m f -> (f -> f -> f) +dataflowMeet FwdDataflowAnalysis { analysisMeet = m } = m +dataflowMeet BwdDataflowAnalysis { analysisMeet = m } = m + +-- | The fixedpoint calculations (and joins) all happen in here. +fixpoint :: forall m f . (Monad m, Eq f) + => Direction + -> DataflowAnalysis m f + -> (Block Insn C C -> Fact C f -> m (Fact C f)) + -> [Label] + -> LabelMap (Block Insn C C) + -> (Fact C f -> m (Fact C f)) +fixpoint dir da doBlock entries blockmap initFbase = + -- See Note [Fixpoint] + loop initFbase entries mempty + where + meet = dataflowMeet da + -- This is a map from label L to all of its dependencies; if L + -- changes, all of its dependencies need to be re-analyzed. + depBlocks :: LabelMap [Label] + depBlocks = mapFromListWith (++) [ (l, [entryLabel b]) + | b <- mapElems blockmap + , l <- case dir of + Fwd -> [entryLabel b] + Bwd -> successors b + ] + + loop :: FactBase f -> [Label] -> Set Label -> m (FactBase f) + loop fbase [] _ = return fbase + loop fbase (lbl:todo) visited = + case mapLookup lbl blockmap of + Nothing -> loop fbase todo (S.insert lbl visited) + Just blk -> do + outFacts <- doBlock blk fbase + -- Fold updateFact over each fact in the result from doBlock + -- updateFact; facts are meet-ed pairwise. + let (changed, fbase') = mapFoldWithKey (updateFact visited) ([], fbase) outFacts + depLookup l = mapFindWithDefault [] l depBlocks + toAnalyze = filter (`notElem` todo) $ concatMap depLookup changed + + -- In the original code, there is a binding @newblocks'@ + -- that includes any new blocks added by the graph rewriting + -- step. This analysis does not rewrite any blocks, so we + -- only need @newblocks@ here. + loop fbase' (todo ++ toAnalyze) (S.insert lbl visited) + + -- We also have a simpler update condition in updateFact since we + -- don't carry around newBlocks. + updateFact :: Set Label + -> Label + -> f + -> ([Label], FactBase f) + -> ([Label], FactBase f) + updateFact visited lbl newFact acc@(cha, fbase) = + case lookupFact lbl fbase of + Nothing -> (lbl:cha, mapInsert lbl newFact fbase) + Just oldFact -> + let fact' = oldFact `meet` newFact + in case fact' == oldFact && S.member lbl visited of + True -> acc + False -> (lbl:cha, mapInsert lbl fact' fbase) + +{- Note [Fixpoint] + +In hoopl, the fixpoint returns a factbase that includes only the facts +that are not in the body. Facts for the body are in the rewritten +body nodes in the DG. Since we are not rewriting the graph, we keep +all facts in the factbase in fixpoint. + +-} + +{- Note [Dataflow Results] + +To get a forward result, we have to look up the result for the block +of the instruction and then run the analysis forward to the target +instruction. + +For a /backward/ analysis, we have to do a bit more. Instead, we need +all of the successors of the block (if there are none, then we have +to take the summary for the unique exit node). Then we have to meet +those and use that as the initial fact. Then replay over the basic +block instructoins /in reverse/. + +Also note that the dataflowResultAt function does not need to use the +edge transfer function because the result replay only needs to work +within a single block. + +-} diff --git a/src/LLVM/Analysis/CallGraph.hs b/src/LLVM/Analysis/CallGraph.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CallGraph.hs @@ -0,0 +1,39 @@ +-- | This module defines a call graph and related functions. The call +-- graph is a static view of the calls between functions in a +-- 'Module'. The nodes of the graph are global functions and the +-- edges are calls made to other functions. +-- +-- This call graph attempts to provide as much information as possible +-- about calls through function pointers. Direct calls have a single +-- outgoing edge. Indirect calls that can be augmented with +-- information from a points-to analysis can induce many IndirectCall +-- edges. +-- +-- For now, all indirect calls also induce an UnknownCall edge, under +-- the assumption that externally-obtained function pointers may also +-- be called somehow. This restriction will eventually be lifted and +-- indirect calls that can be identified as completely internal will +-- not have the UnknownCall edge. The preconditions for this will be: +-- +-- * The 'Module' must have an entry point (otherwise it is a library) +-- +-- * The function pointer must not be able to alias the result of a +-- dlopen or similar call +-- +-- Again, the more sophisticated callgraph is still pending. +module LLVM.Analysis.CallGraph ( + -- * Types + CallGraph, + -- * Constructor + callGraph, + -- * Accessors + callValueTargets, + callSiteTargets, + callGraphFunctions, + functionCallees, + allFunctionCallees, + functionCallers, + allFunctionCallers + ) where + +import LLVM.Analysis.CallGraph.Internal diff --git a/src/LLVM/Analysis/CallGraph/Internal.hs b/src/LLVM/Analysis/CallGraph/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CallGraph/Internal.hs @@ -0,0 +1,658 @@ +{-# LANGUAGE ExistentialQuantification, RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | This internal module implements the CallGraph and the +-- CallGraphSCC traversal together because the traversal depends on +-- CallGraph internals. They are meant to be used through their +-- respective interfaces, but this internal module is accessible in +-- case their APIs are insufficient to do something a user might want. +-- These internals are not stable. +module LLVM.Analysis.CallGraph.Internal ( + -- * Types + CallGraph(..), + CG, + CallEdge(..), + CallNode(..), + -- * Constructor + callGraph, + -- * Accessors + callGraphRepr, + callValueTargets, + callSiteTargets, + callGraphFunctions, + functionCallees, + allFunctionCallees, + functionCallers, + allFunctionCallers, + + -- * CallGraphSCC Traversal + ComposableAnalysis, + callGraphSCCTraversal, + parallelCallGraphSCCTraversal, + + -- * Adaptors + callGraphAnalysis, + callGraphAnalysisM, + callGraphComposeAnalysis, + composableAnalysis, + composableDependencyAnalysis, + composableAnalysisM, + composableDependencyAnalysisM + ) where + +import Control.DeepSeq +import Control.Lens ( Getter, Lens', set, (^.) ) +import Control.Monad ( foldM, replicateM ) +import Control.Monad.Par.Scheds.Direct +import Data.GraphViz ( Labellable(..) ) +import qualified Data.GraphViz as GV +import qualified Data.Graph.Inductive as FGL +import Data.Graph.Inductive.PatriciaTree ( Gr ) +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IM +import qualified Data.List as L +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Hashable +import Data.HashSet ( HashSet ) +import qualified Data.HashSet as HS +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as HM +import Data.Map ( Map ) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Monoid + +import LLVM.Analysis +import LLVM.Analysis.PointsTo + +-- | A type synonym for the underlying graph +type CG = Gr CallNode CallEdge + +-- | The nodes are actually a wrapper type: +data CallNode = DefinedFunction Function + -- ^ An actual function defined in this 'Module' + | ExtFunction ExternalFunction + -- ^ An externally-defined function with a declaration + -- in the 'Module' + | UnknownFunction + -- ^ A function called indirectly that may not have + -- any definition or declaration within the 'Module' + deriving (Eq) + +instance Show CallNode where + show (DefinedFunction v) = show $ functionName v + show (ExtFunction v) = "extern " ++ show (externalFunctionName v) + show UnknownFunction = "unknown" + +instance Labellable CallNode where + toLabelValue = toLabelValue . show + +data CallEdge = DirectCall + -- ^ A static call to a known function + | IndirectCall + -- ^ A possible call to a known function through a + -- function pointer + | UnknownCall + -- ^ A possible call to an unknown function through a + -- function pointer + deriving (Ord, Eq) + +instance Hashable CallEdge where + hashWithSalt s DirectCall = s `hashWithSalt` (1 :: Int) + hashWithSalt s IndirectCall = s `hashWithSalt` (2 :: Int) + hashWithSalt s UnknownCall = s `hashWithSalt` (3 :: Int) + +instance Show CallEdge where + show DirectCall = "" + show IndirectCall = "?" + show UnknownCall = "??" + +instance Labellable CallEdge where + toLabelValue = toLabelValue . show + +-- | An opaque wrapper for the callgraph. The nodes are functions and +-- the edges are calls between them. +data CallGraph = forall pta . (PointsToAnalysis pta) => CallGraph CG pta + +instance ToGraphviz CallGraph where + toGraphviz = cgGraphvizRepr + +-- | Get all of the functions defined in this module from the +-- CallGraph +callGraphFunctions :: CallGraph -> [Function] +callGraphFunctions (CallGraph cg _) = + mapMaybe extractDefinedFunction (FGL.labNodes cg) + where + extractDefinedFunction (_, DefinedFunction f) = Just f + extractDefinedFunction _ = Nothing + +-- | Convert the CallGraph to a graph ADT that can be traversed, +-- manipulated, or easily displayed with graphviz. +-- +-- For now, this representation is not guaranteed to remain stable. +callGraphRepr :: CallGraph -> CG +callGraphRepr (CallGraph g _) = g + +-- | Given a Call or Invoke instruction, return the list of possible +-- callees. All returned Values will be either Functions or +-- ExternalFunctions. +-- +-- Passing a non-call/invoke instruction will trigger a noisy pattern +-- matching failure. +callSiteTargets :: CallGraph -> Instruction -> [Value] +callSiteTargets cg (CallInst { callFunction = f }) = + callValueTargets cg f +callSiteTargets cg (InvokeInst { invokeFunction = f}) = + callValueTargets cg f +callSiteTargets _ i = + error ("LLVM.Analysis.CallGraph.callSiteTargets: Expected a Call or Invoke instruction: " ++ show i) + +-- | Given the value called by a Call or Invoke instruction, return +-- all of the possible Functions or ExternalFunctions that it could +-- be. +callValueTargets :: CallGraph -> Value -> [Value] +callValueTargets (CallGraph _ pta) v = + let v' = stripBitcasts v + in case valueContent v' of + FunctionC _ -> [v'] + ExternalFunctionC _ -> [v'] + _ -> pointsTo pta v + +functionCallees :: CallGraph -> Function -> [Value] +functionCallees (CallGraph g _) = + mapMaybe (toCallValue g) . FGL.suc g . functionUniqueId + +allFunctionCallees :: CallGraph -> Function -> [Value] +allFunctionCallees (CallGraph g _) = + mapMaybe (toCallValue g) . flip FGL.dfs g . (:[]) . functionUniqueId + +functionCallers :: CallGraph -> Function -> [Value] +functionCallers (CallGraph g _) = + mapMaybe (toCallValue g) . FGL.pre g . functionUniqueId + +allFunctionCallers :: CallGraph -> Function -> [Value] +allFunctionCallers (CallGraph g _) = + mapMaybe (toCallValue g) . flip FGL.rdfs g . (:[]) . functionUniqueId + +toCallValue :: CG -> Vertex -> Maybe Value +toCallValue g v = do + l <- FGL.lab g v + case l of + DefinedFunction f -> return (toValue f) + ExtFunction ef -> return (toValue ef) + _ -> Nothing + +-- | Build a call graph for the given 'Module' using a pre-computed +-- points-to analysis. The String parameter identifies the program +-- entry point. +-- +-- FIXME: @entryPoint@ is not respected. +-- +-- FIXME: Function pointers can be bitcasted - be sure to respect +-- those when adding indirect edges. +callGraph :: (PointsToAnalysis a) + => Module + -> a -- ^ A points-to analysis (to resolve function pointers) + -> [Function] -- ^ The entry points to the 'Module' + -> CallGraph +callGraph m pta _ {-entryPoints-} = + CallGraph (FGL.mkGraph allNodes (unique allEdges)) pta + where + allNodes = concat [ knownNodes, unknownNodes, externNodes ] + (allEdges, unknownNodes) = buildEdges pta funcs + -- ^ Build up all of the edges and accumulate unknown nodes as + -- they are created on-the-fly + knownNodes = map (\f -> (valueUniqueId f, DefinedFunction f)) funcs + -- ^ Add nodes for unknown functions (one unknown node for each + -- type signature in an indirect call). The unknown nodes can use + -- negative numbers for nodeids since actual Value IDs start at 0. + + externNodes = map mkExternFunc $ moduleExternalFunctions m + + funcs = moduleDefinedFunctions m + +unique :: (Hashable a, Eq a) => [a] -> [a] +unique = HS.toList . HS.fromList + +type Vertex = FGL.Node +type Edge = FGL.LEdge CallEdge + +-- | This is the ID for the single "Unknown function" call graph node. +unknownNodeId :: Vertex +unknownNodeId = -100 + +mkExternFunc :: ExternalFunction -> (Vertex, CallNode) +mkExternFunc v = (valueUniqueId v, ExtFunction v) + +buildEdges :: (PointsToAnalysis a) => a -> [Function] -> ([Edge], [(Vertex, CallNode)]) +buildEdges pta funcs = do + let es = map (buildFuncEdges pta) funcs + unknownNodes = [(unknownNodeId, UnknownFunction)] + (concat es, unknownNodes) + +isCall :: Instruction -> Bool +isCall CallInst {} = True +isCall InvokeInst {} = True +isCall _ = False + +buildFuncEdges :: (PointsToAnalysis a) => a -> Function -> [Edge] +buildFuncEdges pta f = concat es + where + insts = concatMap basicBlockInstructions $ functionBody f + calls = filter isCall insts + es = map (buildCallEdges pta f) calls + +getCallee :: Instruction -> Value +getCallee CallInst { callFunction = f } = f +getCallee InvokeInst { invokeFunction = f } = f +getCallee i = error ("LLVM.Analysis.CallGraph.getCallee: Expected a function in getCallee: " ++ show i) + +buildCallEdges :: (PointsToAnalysis a) => a -> Function -> Instruction -> [Edge] +buildCallEdges pta caller callInst = build' (getCallee callInst) + where + callerId = valueUniqueId caller + build' calledFunc = + case valueContent' calledFunc of + FunctionC f -> + [(callerId, valueUniqueId f, DirectCall)] + GlobalAliasC GlobalAlias { globalAliasTarget = aliasee } -> + [(callerId, valueUniqueId aliasee, DirectCall)] + ExternalFunctionC ef -> + [(callerId, valueUniqueId ef, DirectCall)] + -- Functions can be bitcasted before being called - trace + -- through those to find the underlying function + InstructionC BitcastInst { castedValue = bcv } -> build' bcv + _ -> + let targets = resolveIndirectCall pta callInst + indirectEdges = map (\t -> (callerId, valueUniqueId t, IndirectCall)) targets + unknownEdge = (callerId, unknownNodeId, UnknownCall) + in unknownEdge : indirectEdges + +cgGraphvizParams :: HashMap Int Int -> HashSet Int -> GV.GraphvizParams Int CallNode CallEdge Int CallNode +cgGraphvizParams compMap singletons = + GV.defaultParams { GV.fmtNode = \(_,l) -> [GV.toLabel l] + , GV.fmtEdge = \(_,_,l) -> [GV.toLabel l] + , GV.clusterBy = clusterByFunc + , GV.clusterID = clusterIDFunc + } + where + clusterIDFunc cid = + case cid `HS.member` singletons of + True -> GV.Str "" + False -> GV.Int cid + clusterByFunc n@(nid, _) = + let cid = HM.lookupDefault (-1) nid compMap + in case cid `HS.member` singletons of + True -> GV.N n + False -> GV.C cid (GV.N n) + +cgGraphvizRepr :: CallGraph -> GV.DotGraph Int +cgGraphvizRepr (CallGraph g _) = + GV.graphElemsToDot (cgGraphvizParams compMap singletons) ns es + where + ns = FGL.labNodes g + es = FGL.labEdges g + comps = zip [0..] $ FGL.scc g + singletons = HS.fromList $ map fst $ filter ((==0) . length . snd) comps + compMap = foldr assignComponent mempty comps + +assignComponent :: (Int, [Int]) -> HashMap Int Int -> HashMap Int Int +assignComponent (compId, nodeIds) acc = + foldr (\nid -> HM.insert nid compId) acc nodeIds + + +-- CallGraphSCC Traversal + +type FunctionGraph = Gr Function () +type SCCGraph = Gr [(Vertex, Function)] () + +-- | An abstract representation of a composable analysis. Construct +-- these with the smart constructors 'composableAnalysis', +-- 'composableDependencyAnalysis', 'composableAnalysisM', and +-- 'composableDependencyAnalysisM'. +-- +-- Use 'callGraphComposeAnalysis' to convert a list of these into a +-- summary function for use with the call graph traversals. +data ComposableAnalysis compSumm funcLike = + forall summary m . (NFData summary, Monoid summary, Eq summary, Monad m) + => ComposableAnalysisM { analysisUnwrap :: m summary -> summary + , analysisFunctionM :: funcLike -> summary -> m summary + , summaryLens :: Lens' compSumm summary + } + | forall summary deps m . (NFData summary, Monoid summary, Eq summary, Monad m) + => ComposableAnalysisDM { analysisUnwrap :: m summary -> summary + , analysisFunctionDM :: deps -> funcLike -> summary -> m summary + , summaryLens :: Lens' compSumm summary + , dependencyLens :: Getter compSumm deps + } + | forall summary . (NFData summary, Monoid summary, Eq summary) + => ComposableAnalysis { analysisFunction :: funcLike -> summary -> summary + , summaryLens :: Lens' compSumm summary + } + | forall summary deps . (NFData summary, Monoid summary, Eq summary) + => ComposableAnalysisD { analysisFunctionD :: deps -> funcLike -> summary -> summary + , summaryLens :: Lens' compSumm summary + , dependencyLens :: Getter compSumm deps + } + + +-- | Traverse the callgraph bottom-up with an accumulator function. +-- +-- > callGraphSCCTraversal cg f seed +-- +-- This example applies the folding function @f@ over each +-- strongly-connected component in the callgraph bottom-up with a +-- starting @seed@. Each strongly-connected component is processed as +-- a unit. The final accumulated value (based on @seed@) is returned. +-- +-- The function @f@ is responsible for approximating the analysis +-- value for the SCC in whatever way makes sense for the analysis. +callGraphSCCTraversal :: (FuncLike funcLike) + => CallGraph -- ^ The callgraph + -> ([funcLike] -> summary -> summary) -- ^ A function to process a strongly-connected component + -> summary -- ^ An initial summary value + -> summary +callGraphSCCTraversal callgraph f seed = + foldr applyAnalysis seed sccList + -- Note, have to reverse the list here to process in bottom-up order + -- since foldM is a left fold + -- + -- NOTE now not reversing the SCC list because it is now a right + -- fold + where + cg = definedCallGraph callgraph + sccList = FGL.topsort' cg + applyAnalysis component = + f (map (fromFunction . snd) component) + +-- | The projection of the call graph containing only defined +-- functions (no externals) +definedCallGraph :: CallGraph -> SCCGraph +definedCallGraph = condense . projectDefinedFunctions . callGraphRepr + +-- FIXME: Have this function take a list of funcLikes; it will +-- construct a @Map Function funcLike@ and pass that down to the +-- thread spawner, which will do map lookups instead of re-computing +-- the funcLike each time. + +-- | Just like 'callGraphSCCTraversal', except strongly-connected +-- components are analyzed in parallel. Each component is analyzed as +-- soon as possible after its dependencies have been analyzed. +parallelCallGraphSCCTraversal :: (NFData summary, Monoid summary, FuncLike funcLike) + => CallGraph + -> ([funcLike] -> summary -> summary) + -> summary + -> summary +parallelCallGraphSCCTraversal callgraph f seed = runPar $ do + -- Make an output variable for each SCC in the call graph. + outputVars <- replicateM (FGL.noNodes cg) new + let sccs = FGL.labNodes cg + varMap = M.fromList (zip (map fst sccs) outputVars) + sccsWithVars = map (attachVars cg varMap) sccs + + -- Spawn a thread for each SCC that waits until its dependencies are + -- analyzed (by blocking on the IVars above). Each SCC fills its + -- IVar after it has been analyzed. + -- + -- The fold accumulates the output vars of the functions that are + -- not depended on by any others. These are the roots of the call + -- graph and combining their summaries will yield the summary for + -- the whole library. This selectivity is explicit so that we + -- retain as few outputVars as possible. If we retain all of the + -- output vars for the duration of the program, we get an explosion + -- of retained summaries and waste a lot of space. + rootOutVars <- foldM (forkSCC f seed) [] (force sccsWithVars) + + -- Merge all of the results from all of the SCCs + finalVals <- mapM get rootOutVars + return $! mconcat finalVals + where + cg = definedCallGraph callgraph + +attachVars :: SCCGraph -> Map Int (IVar summary) -> (Vertex, [(Vertex, Function)]) + -> ([Function], [IVar summary], IVar summary, Bool) +attachVars cg varMap (nid, component) = + (map snd component, inVars, outVar, isRoot) + where + outVar = varMap M.! nid + inVars = map (getDep varMap) deps + deps = filter (/=nid) $ FGL.suc cg nid + isRoot = null (FGL.pre cg nid) + +-- | Fork off a thread (using the Par monad) to process a +-- strongly-connected component in the call graph in its own thread. +-- The thread will block on IVars until the components dependencies +-- have been analyzed. When the component is analyzed, it will fill +-- its IVar with a value to unblock the other threads waiting on it. +forkSCC :: (NFData summary, Monoid summary, FuncLike funcLike) + => ([funcLike] -> summary -> summary) -- ^ The summary function to apply + -> summary -- ^ The seed value + -> [IVar summary] + -> ([Function], [IVar summary], IVar summary, Bool) + -> Par [IVar summary] +forkSCC f val0 acc (component, inVars, outVar, isRoot) = do + fork $ do + -- SCCs can contain self-loops in the condensed call graph, so + -- remove those self loops here so we don't block the entire + -- parallel computation with a thread waiting on itself. + depVals <- mapM get inVars + let seed = case null inVars of + True -> val0 + False -> force $ mconcat depVals + -- FIXME parmap + funcLikes = map fromFunction component + sccSummary = f funcLikes seed + put outVar sccSummary + case isRoot of + False -> return acc + True -> return (outVar : acc) + +-- | Make a call-graph SCC summary function from a basic monadic +-- summary function and a function to evaluate the function in its +-- monad and unwrap the monadic value. +-- +-- The monadic equivalent of 'callGraphAnalysis'. +callGraphAnalysisM :: (FuncLike funcLike, Eq summary, Monad m) + => (m summary -> summary) -- ^ A function to unwrap a monadic result from the summary + -> (funcLike -> summary -> m summary) -- ^ Summary function + -> ([funcLike] -> summary -> summary) +callGraphAnalysisM unwrap analyzeFunc = f + where + f [singleFunc] summ = unwrap $ analyzeFunc singleFunc summ + f funcs summ = unwrap $ go funcs summ + + go funcs summ = do + newSumm <- foldM (flip analyzeFunc) summ funcs + case newSumm == summ of + True -> return summ + False -> go funcs newSumm + +-- | Make a call-graph SCC summary function from a pure summary +-- function. The function is applied to each function in the SCC in +-- an arbitrary order. It returns the resulting summary obtained by +-- repeated evaluation until a fixed-point is reached. +callGraphAnalysis :: (FuncLike funcLike, Eq summary) + => (funcLike -> summary -> summary) + -> ([funcLike] -> summary -> summary) +callGraphAnalysis analyzeFunc = f + where + f [singleFunc] summ = analyzeFunc singleFunc summ + f funcs summ = + let newSumm = foldr analyzeFunc summ funcs + in case newSumm == summ of + True -> summ + False -> f funcs newSumm + +-- | Compose a list of analyses into a pure summary function for use +-- in a callGraphSCCTraversal. The advantage of using a composable +-- analysis is that it only traverses the call graph once. At each +-- SCC, all analyses are applied until their fixed-point is reached. +-- +-- This makes it easier to share intermediate values (like CFGs) +-- between analyses without having to recompute them or store them on +-- the side. +-- +-- The input analyses are processed *in order* (left-to-right). This +-- means that analyses with dependencies should come *after* the +-- analyses they depend on in the list. This is not currently +-- statically enforced - your dependency summaries will just be +-- missing information you might have expected if you get the order +-- wrong. +callGraphComposeAnalysis :: (FuncLike funcLike, Monoid compSumm, Eq compSumm) + => [ComposableAnalysis compSumm funcLike] + -> ([funcLike] -> compSumm -> compSumm) +callGraphComposeAnalysis analyses = f + where + f funcs summ = + L.foldl' (applyAnalysisN funcs) summ analyses + + applyAnalysisN funcs summ a@ComposableAnalysisM { analysisUnwrap = unwrap + , analysisFunctionM = af + , summaryLens = lns + } = + let inputSummary = summ ^. lns + res = unwrap $ foldM (flip af) inputSummary funcs + in case res == inputSummary of + True -> summ + False -> applyAnalysisN funcs (set lns res summ) a + applyAnalysisN funcs summ a@ComposableAnalysisDM { analysisUnwrap = unwrap + , analysisFunctionDM = af + , summaryLens = lns + , dependencyLens = dlns + } = + let inputSummary = summ ^. lns + deps = summ ^. dlns + af' = af deps + res = unwrap $ foldM (flip af') inputSummary funcs + in case res == inputSummary of + True -> summ + False -> applyAnalysisN funcs (set lns res summ) a + applyAnalysisN funcs summ a@ComposableAnalysis { analysisFunction = af + , summaryLens = lns + } = + let inputSummary = summ ^. lns + res = foldr af inputSummary funcs + in case res == inputSummary of + True -> summ + False -> applyAnalysisN funcs (set lns res summ) a + applyAnalysisN funcs summ a@ComposableAnalysisD { analysisFunctionD = af + , summaryLens = lns + , dependencyLens = dlns + } = + let inputSummary = summ ^. lns + deps = summ ^. dlns + res = foldr (af deps) inputSummary funcs + in case res == inputSummary of + True -> summ + False -> applyAnalysisN funcs (set lns res summ) a + + +-- | A monadic version of 'composableAnalysis'. The first argument +-- here is a function to unwrap a monadic value (something like +-- runIdentity or runReader). +composableAnalysisM :: (NFData summary, Monoid summary, Eq summary, Monad m, FuncLike funcLike) + => (m summary -> summary) + -> (funcLike -> summary -> m summary) + -> Lens' compSumm summary + -> ComposableAnalysis compSumm funcLike +composableAnalysisM = ComposableAnalysisM + +-- | A monadic version of 'composableDependencyAnalysis'. +composableDependencyAnalysisM :: (NFData summary, Monoid summary, Eq summary, Monad m, FuncLike funcLike) + => (m summary -> summary) + -> (deps -> funcLike -> summary -> m summary) + -> Lens' compSumm summary + -> Getter compSumm deps + -> ComposableAnalysis compSumm funcLike +composableDependencyAnalysisM = ComposableAnalysisDM + +-- | Create a pure composable analysis from a summary function and a +-- Lens that accesses the summary for this function (given the +-- composite summary). The lens is used to access the current state +-- of this analysis and to update the state for this analysis after it +-- is run. +composableAnalysis :: (NFData summary, Monoid summary, Eq summary, FuncLike funcLike) + => (funcLike -> summary -> summary) + -> Lens' compSumm summary + -> ComposableAnalysis compSumm funcLike +composableAnalysis = ComposableAnalysis + +-- | Like 'composableAnalysis', but with an extra lens that is used to +-- extract *dependency* information from the composite summary, which +-- is then fed into this summary function. +-- +-- The intended use is that some analysis will have a dependency on an +-- earlier analysis summary. The lens is used to extract the relevant +-- part of the composite summary. A dependency on multiple earlier +-- analysis summaries can be expressed by providing a lens that +-- extracts a *tuple* containing all relevant analyses. +composableDependencyAnalysis :: (NFData summary, Monoid summary, Eq summary, FuncLike funcLike) + => (deps -> funcLike -> summary -> summary) + -> Lens' compSumm summary + -> Getter compSumm deps + -> ComposableAnalysis compSumm funcLike +composableDependencyAnalysis = ComposableAnalysisD + + + + +-- Helpers + +projectDefinedFunctions :: CG -> FunctionGraph +projectDefinedFunctions g = FGL.mkGraph ns' es' + where + es = FGL.labEdges g + ns = FGL.labNodes g + ns' = foldr keepDefinedFunctions [] ns + es' = map (\(s, d, _) -> (s, d, ())) $ filter (edgeIsBetweenDefined m) es + m = M.fromList ns + +keepDefinedFunctions :: (Vertex, CallNode) + -> [(Vertex, Function)] + -> [(Vertex, Function)] +keepDefinedFunctions (nid, DefinedFunction f) acc = (nid, f) : acc +keepDefinedFunctions _ acc = acc + +edgeIsBetweenDefined :: Map Int CallNode -> Edge -> Bool +edgeIsBetweenDefined m (src, dst, _) = + nodeIsDefined m src && nodeIsDefined m dst + +nodeIsDefined :: Map Int CallNode -> Int -> Bool +nodeIsDefined m n = + case M.lookup n m of + Just (DefinedFunction _) -> True + _ -> False + +getDep :: Map Int c -> Int -> c +getDep m n = fromMaybe errMsg (M.lookup n m) + where + errMsg = error ("LLVM.Analysis.CallGraphSCCTraversal.getDep: Missing expected output var for node: " ++ show n) + +-- Some of the type signatures have redundant brackets to emphasize +-- that they are intended to be partially applied. + +condense :: FunctionGraph -> SCCGraph +condense gr = FGL.mkGraph ns es + where + sccIds = zip [0..] (FGL.scc gr) + nodeToSccMap = foldr buildSccIdMap mempty sccIds + ns = map (sccToNode gr) sccIds + es = S.toList $ foldr (collectEdges nodeToSccMap) mempty (FGL.edges gr) + +buildSccIdMap :: (Int, [Vertex]) -> IntMap Int -> IntMap Int +buildSccIdMap (cid, ns) acc = + foldr (\n -> IM.insert n cid) acc ns + +sccToNode :: (FGL.Graph gr) => gr a b -> (t, [FGL.Node]) -> (t, [FGL.LNode a]) +sccToNode g (sccId, ns) = (sccId, map toNode ns) + where + toNode = FGL.labNode' . FGL.context g + +collectEdges :: IntMap Vertex + -> FGL.Edge + -> S.Set (FGL.LEdge ()) + -> S.Set (FGL.LEdge ()) +collectEdges nodeToSccMap (s, d) !acc = + let Just s' = IM.lookup s nodeToSccMap + Just d' = IM.lookup d nodeToSccMap + in S.insert (s', d', ()) acc diff --git a/src/LLVM/Analysis/CallGraphSCCTraversal.hs b/src/LLVM/Analysis/CallGraphSCCTraversal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/CallGraphSCCTraversal.hs @@ -0,0 +1,32 @@ +-- | This module provides a framework for analyzing LLVM Modules +-- bottom-up with regard to the call graph. The analysis starts at +-- the leaves and propagates summary information up the call graph. +-- Strongly-connected components (hence the SCC in the module name) +-- are analyzed until a fixed-point is reached. +-- +-- Analysis functions can be either pure or monadic; the adaptors take +-- summary functions of various shapes and convert them into a form +-- suitable for the traversal engine. +-- +-- The traversal also processes independent strongly-connected +-- components in parallel with as many cores as the process has been +-- allocated. +module LLVM.Analysis.CallGraphSCCTraversal ( + -- * Traversals + callGraphSCCTraversal, + parallelCallGraphSCCTraversal, + + -- * Types + ComposableAnalysis, + + -- * Adaptors + callGraphAnalysis, + callGraphAnalysisM, + callGraphComposeAnalysis, + composableAnalysis, + composableDependencyAnalysis, + composableAnalysisM, + composableDependencyAnalysisM, + ) where + +import LLVM.Analysis.CallGraph.Internal diff --git a/src/LLVM/Analysis/ClassHierarchy.hs b/src/LLVM/Analysis/ClassHierarchy.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/ClassHierarchy.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE ViewPatterns #-} +-- | This module defines a class hierarchy analysis for C++. +-- +-- This analysis operates entirely at the bitcode level and does not +-- rely on metadata. +-- +-- The hierarchy analysis result only includes class instantiations in +-- the bitcode provided (i.e., it is most useful for whole-program +-- bitcodes). Results for single compilation units will be +-- incomplete. +-- +-- Also note that this analysis requires the input bitcode to be built +-- with C++ run-time type information. +module LLVM.Analysis.ClassHierarchy ( + -- * Types + CHA, + VTable, + -- * Functions + resolveVirtualCallee, + classSubtypes, + classTransitiveSubtypes, + classParents, + classAncestors, + classVTable, + functionAtSlot, + runCHA, + -- * Testing + classHierarchyToTestFormat + ) where + +import ABI.Itanium +import Data.Foldable ( foldMap, toList ) +import Data.Generics.Uniplate.Data +import Data.List ( stripPrefix ) +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Monoid +import Data.Set ( Set ) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Vector ( Vector, (!?) ) +import qualified Data.Vector as V + +import LLVM.Analysis hiding ( (!?) ) +import LLVM.Analysis.Util.Names + +-- | The result of the class hierarchy analysis +data CHA = CHA { childrenMap :: Map Name (Set Name) + -- ^ All classes derived from the class used as the map key + , parentMap :: Map Name (Set Name) + -- ^ The parent classes of the map key + , vtblMap :: Map Name VTable + -- ^ The virtual function pointer table for the map key + , typeMapping :: Map Name Type + -- ^ A relation between ABI names and LLVM Types + , chaModule :: Module + -- ^ A saved reference to the module + } + +-- Note that all keys are by Name here. The name is the name of the +-- class, with conversions done between LLVM types and Names +-- as-needed. This is simplest because it isn't possible to get an +-- LLVM type at all stages of the analysis - those can only be +-- reconstructed after the entire module is analyzed. Since LLVM +-- records namespace information in class type names, this process is +-- robust enough. + +-- | An interface for inspecting virtual function tables +data VTable = ExternalVTable + | VTable (Vector Function) + deriving (Show) + +resolveVirtualCallee :: CHA -> Instruction -> Maybe [Function] +resolveVirtualCallee cha i = + case i of + -- Resolve direct calls (note, this does not cover calls to + -- external functions, unfortunately). + CallInst { callFunction = (valueContent' -> FunctionC f) } -> Just [f] + -- Resolve actual virtual dispatches. Note that the first + -- argument is always the @this@ pointer. + CallInst { callFunction = (valueContent' -> InstructionC LoadInst { loadAddress = la }) + , callArguments = (thisVal, _) : _ + } -> + virtualDispatch cha la thisVal + InvokeInst { invokeFunction = (valueContent' -> FunctionC f) } -> Just [f] + InvokeInst { invokeFunction = (valueContent' -> InstructionC LoadInst { loadAddress = la }) + , invokeArguments = (thisVal, _) : _ + } -> + virtualDispatch cha la thisVal + _ -> Nothing + +-- | Dispatch to one of the vtable lookup strategies based on the +-- value that was loaded from the vtable. +virtualDispatch :: CHA -> Value -> Value -> Maybe [Function] +virtualDispatch cha loadAddr thisVal = do + slotNumber <- getVFuncSlot cha loadAddr thisVal + return $! mapMaybe (functionAtSlot slotNumber) vtbls + where + TypePointer thisType _ = valueType thisVal + derivedTypes = classTransitiveSubtypes cha thisType + vtbls = mapMaybe (classVTable cha) derivedTypes + +-- | Identify the slot number of a virtual function call. Basically, +-- work backwards from the starred instructions in the virtual +-- function call dispatch patterns: +-- +-- clang: +-- +-- %2 = bitcast %struct.Base* %0 to void (%struct.Base*)*** +-- %vtable = load void (%struct.Base*)*** %2 +-- %vfn = getelementptr inbounds void (%struct.Base*)** %vtable, i64 1 +-- * %3 = load void (%struct.Base*)** %vfn +-- call void %3(%struct.Base* %0) +-- +-- clang0: +-- +-- %0 = bitcast %struct.Base* %b to void (%struct.Base*)*** +-- %vtable = load void (%struct.Base*)*** %0 +-- * %1 = load void (%struct.Base*)** %vtable +-- call void %1(%struct.Base* %b) +-- +-- dragonegg: +-- +-- %2 = getelementptr inbounds %struct.Base* %1, i32 0, i32 0 +-- %3 = load i32 (...)*** %2, align 4 +-- %4 = bitcast i32 (...)** %3 to i8* +-- %5 = getelementptr i8* %4, i32 4 +-- %6 = bitcast i8* %5 to i32 (...)** +-- * %7 = load i32 (...)** %6, align 4 +-- %8 = bitcast i32 (...)* %7 to void (%struct.Base*)* +-- call void %8(%struct.Base* %1) +-- +-- dragonegg0 (first method slot): +-- +-- %2 = getelementptr inbounds %struct.Base* %1, i32 0, i32 0 +-- %3 = load i32 (...)*** %2, align 4 +-- * %4 = load i32 (...)** %3, align 4 +-- %5 = bitcast i32 (...)* %4 to void (%struct.Base*)* +-- call void %5(%struct.Base* %1) +getVFuncSlot :: CHA -> Value -> Value -> Maybe Int +getVFuncSlot cha loadAddr thisArg = + case valueContent loadAddr of + -- Clang style + InstructionC GetElementPtrInst { + getElementPtrIndices = [valueContent -> ConstantC ConstantInt { constantIntValue = slotNo }], + getElementPtrValue = + (valueContent -> InstructionC LoadInst { + loadAddress = + (valueContent -> InstructionC BitcastInst { + castedValue = thisPtr + })})} -> + case thisArg == thisPtr of + True -> return $! fromIntegral slotNo + False -> Nothing + InstructionC LoadInst { + loadAddress = (valueContent -> InstructionC BitcastInst { + castedValue = base})} -> + case thisArg == base of + True -> return 0 + False -> Nothing + -- Dragonegg0 style (slot 0 call) + InstructionC LoadInst { + loadAddress = + (valueContent -> InstructionC GetElementPtrInst { + getElementPtrIndices = [ valueContent -> ConstantC ConstantInt { constantIntValue = 0 } + , valueContent -> ConstantC ConstantInt { constantIntValue = 0 } + ], + getElementPtrValue = thisPtr})} -> + case thisArg == thisPtr of + True -> return 0 + False -> Nothing + -- Dragonegg general case + InstructionC BitcastInst { + castedValue = + (valueContent -> InstructionC GetElementPtrInst { + getElementPtrIndices = [valueContent -> ConstantC ConstantInt { constantIntValue = offset }], + getElementPtrValue = + (valueContent -> InstructionC BitcastInst { + castedValue = + (valueContent -> InstructionC LoadInst { + loadAddress = + (valueContent -> InstructionC GetElementPtrInst { + getElementPtrIndices = [ valueContent -> ConstantC ConstantInt { constantIntValue = 0 } + , valueContent -> ConstantC ConstantInt { constantIntValue = 0 } + ], + getElementPtrValue = thisPtr})})})})} -> + case thisArg == thisPtr of + True -> Just $! indexFromOffset cha (fromIntegral offset) + False -> Nothing + _ -> Nothing + +indexFromOffset :: CHA -> Int -> Int +indexFromOffset cha bytes = (bytes * 8) `div` pointerBits + where + m = chaModule cha + targetData = moduleDataLayout m + pointerBits = alignmentPrefSize (targetPointerPrefs targetData) + +-- | List of all types derived from the given 'Type'. +classSubtypes :: CHA -> Type -> [Type] +classSubtypes cha t = + namesToTypes cha (M.findWithDefault mempty (typeToName t) (childrenMap cha)) + +-- | List of all types *transitively* drived from the given 'Type' +classTransitiveSubtypes :: CHA -> Type -> [Type] +classTransitiveSubtypes = transitiveTypes childrenMap + +-- | List of the immediate parent types of the given 'Type'. The list +-- is only empty for the root of a class hierarchy. +classParents :: CHA -> Type -> [Type] +classParents cha t = + namesToTypes cha (M.findWithDefault mempty (typeToName t) (parentMap cha)) + +-- | List of all (transitive) parent types of the given 'Type'. +classAncestors :: CHA -> Type -> [Type] +classAncestors = transitiveTypes parentMap + +transitiveTypes :: (CHA -> Map Name (Set Name)) -> CHA -> Type -> [Type] +transitiveTypes selector cha t0 = + namesToTypes cha (go (S.singleton (typeToName t0))) + where + go ts = + let nextLevel = foldMap getParents ts + in case mempty == nextLevel of + True -> ts + False -> go nextLevel `mappend` ts + getParents t = M.findWithDefault mempty t (selector cha) + +-- | Retrieve the vtbl for a given type. Will return Nothing if the +-- type is not a class or if the class has no virtual methods. +classVTable :: CHA -> Type -> Maybe VTable +classVTable cha t = M.lookup (typeToName t) (vtblMap cha) + +-- | Get the function at the named slot in a vtable. Returns Nothing +-- for external vtables. +functionAtSlot :: Int -> VTable -> Maybe Function +functionAtSlot _ ExternalVTable = Nothing +functionAtSlot slot (VTable v) = v !? slot + +-- | The analysis reconstructs the class hierarchy by looking at +-- typeinfo structures (which are probably only generated when +-- compiling with run-time type information enabled). It also finds +-- vtables by demangling the names of the vtables in the module. +runCHA :: Module -> CHA +runCHA m = foldr buildTypeMap cha1 ctors + where + gvs = moduleGlobalVariables m + ctors = moduleConstructors m + cha0 = CHA mempty mempty mempty mempty m + cha1 = foldr recordParents cha0 gvs + +moduleConstructors :: Module -> [Function] +moduleConstructors = filter isC2Constructor . moduleDefinedFunctions + +-- | Fill in the mapping from Names to LLVM Types in the class +-- hierarchy analysis by examining the first argument of each +-- constructor. This argument indicates the LLVM type of the type +-- being constructed; parsing the LLVM type name into a Name yields +-- the map key. +buildTypeMap :: Function -> CHA -> CHA +buildTypeMap f cha = + case parseTypeName fname of + Left e -> error ("LLVM.Analysis.ClassHierarchy.buildTypeMap: " ++ e) + Right n -> + cha { typeMapping = M.insert n t (typeMapping cha) } + where + t = constructedType f + fname = case t of + TypeStruct (Right tn) _ _ -> stripNamePrefix (T.unpack tn) + _ -> error ("LLVM.Analysis.ClassHierarchy.buildTypeMap: Expected class type: " ++ show t) + +-- | Determine the parent classes for each class type (if any) and +-- record them in the class hierarchy analysis summary. This +-- information is derived from the typeinfo structures. Additionally, +-- record the vtable for each type. +recordParents :: GlobalVariable -> CHA -> CHA +recordParents gv acc = + case dname of + Left _ -> acc + Right structuredName -> + case structuredName of + VirtualTable (ClassEnumType typeName) -> + recordVTable acc typeName (globalVariableInitializer gv) + VirtualTable tn -> error ("LLVM.Analysis.ClassHierarchy.recordParents: Expected a class name for virtual table: " ++ show tn) + TypeInfo (ClassEnumType typeName) -> + recordTypeInfo acc typeName (globalVariableInitializer gv) + TypeInfo tn -> error ("LLVM.Analysis.ClassHierarchy.recordParents: Expected a class name for typeinfo: " ++ show tn) + _ -> acc + where + n = identifierAsString (globalVariableName gv) + dname = demangleName n + +-- | Record the vtable by storing only the function pointers from the +recordVTable :: CHA -> Name -> Maybe Value -> CHA +recordVTable cha typeName Nothing = + cha { vtblMap = M.insert typeName ExternalVTable (vtblMap cha) } +recordVTable cha typeName (Just v) = + case valueContent' v of + ConstantC (ConstantArray _ _ vs) -> + cha { vtblMap = M.insert typeName (makeVTable vs) (vtblMap cha) } + _ -> recordVTable cha typeName Nothing + +-- | Build a VTable given the list of values in the vtable array. The +-- actual vtable (as indexed) doesn't begin at index zero, so we drop +-- all of the values that are not functions, then take everything that +-- is. +makeVTable :: [Value] -> VTable +makeVTable = + VTable . V.fromList . map unsafeToFunction . takeWhile isVTableFunctionType . dropWhile (not . isVTableFunctionType) + +unsafeToFunction :: Value -> Function +unsafeToFunction v = + case valueContent' v of + FunctionC f -> f + _ -> error ("LLVM.Analysis.ClassHierarchy.unsafeToFunction: Expected vtable function entry: " ++ show v) + + +isVTableFunctionType :: Value -> Bool +isVTableFunctionType v = + case valueContent' v of + FunctionC _ -> True + _ -> False + +recordTypeInfo :: CHA -> Name -> Maybe Value -> CHA +recordTypeInfo cha _ Nothing = cha +recordTypeInfo cha name (Just tbl) = + case valueContent tbl of + ConstantC (ConstantStruct _ _ vs) -> + let parentClassNames = mapMaybe toParentClassName vs + in cha { parentMap = M.insertWith' S.union name (S.fromList parentClassNames) (parentMap cha) + , childrenMap = foldr (addChild name) (childrenMap cha) parentClassNames + } + _ -> error ("LLVM.Analysis.ClassHierarchy.recordTypeInfo: Expected typeinfo literal " ++ show tbl) + +toParentClassName :: Value -> Maybe Name +toParentClassName v = + case valueContent v of + ConstantC ConstantValue { + constantInstruction = BitcastInst { + castedValue = (valueContent -> GlobalVariableC GlobalVariable { + globalVariableName = gvn })}} -> + case demangleName (identifierAsString gvn) of + Left _ -> Nothing + Right (TypeInfo (ClassEnumType n)) -> Just n + _ -> Nothing + _ -> Nothing + +addChild :: Name -> Name -> Map Name (Set Name) -> Map Name (Set Name) +addChild thisType parentType = + M.insertWith' S.union parentType (S.singleton thisType) + +constructedType :: Function -> Type +constructedType f = + case map argumentType $ functionParameters f of + TypePointer t@(TypeStruct (Right _) _ _) _ : _ -> t + t -> error ("LLVM.Analysis.ClassHierarchy.constructedType: Expected pointer to struct type: " ++ show t) + +-- Helpers + +-- | Determine if the given function is a C2 constructor or not. C1 +-- and C3 don't give us the information we want, so ignore them +isC2Constructor :: Function -> Bool +isC2Constructor f = + case dname of + Left _ -> False + Right structuredName -> + case universeBi structuredName of + [C2] -> True + _ -> False + where + n = identifierAsString (functionName f) + dname = demangleName n + +-- | Strip a prefix, operating as the identity if the input string did +-- not have the prefix. +stripPrefix' :: String -> String -> String +stripPrefix' pfx s = fromMaybe s (stripPrefix pfx s) + +stripNamePrefix :: String -> String +stripNamePrefix = + stripPrefix' "struct." . stripPrefix' "class." + +typeToName :: Type -> Name +typeToName (TypeStruct (Right n) _ _) = + case parseTypeName (stripNamePrefix (T.unpack n)) of + Right tn -> tn + Left e -> error ("LLVM.Analysis.ClassHierarchy.typeToName: " ++ e) +typeToName t = error ("LLVM.Analysis.ClassHierarchy.typeToName: Expected named struct type: " ++ show t) + +nameToString :: Name -> String +nameToString n = fromMaybe errMsg (unparseTypeName n) + where + errMsg = error ("Could not encode name as string: " ++ show n) + +nameToType :: CHA -> Name -> Type +nameToType cha n = M.findWithDefault errMsg n (typeMapping cha) + where + errMsg = error ("Expected name in typeMapping for CHA: " ++ show n) + +namesToTypes :: CHA -> Set Name -> [Type] +namesToTypes cha = map (nameToType cha) . toList + + +-- Testing + +classHierarchyToTestFormat :: CHA -> Map String (Set String) +classHierarchyToTestFormat cha = + foldr mapify mempty (M.toList (childrenMap cha)) + where + mapify (ty, subtypes) = + let ss = S.map nameToString subtypes + in M.insertWith S.union (nameToString ty) ss + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/src/LLVM/Analysis/Dataflow.hs b/src/LLVM/Analysis/Dataflow.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/Dataflow.hs @@ -0,0 +1,37 @@ +-- | This module defines an interface for intra-procedural dataflow +-- analysis (forward and backward). +-- +-- The user defines an analysis with the 'dataflowAnalysis' function, +-- which can be constructed from a 'top' value, a 'meet' operator, and +-- a 'transfer' function (which is run as needed for 'Instruction's). +-- +-- To use this dataflow analysis framework, pass it an initial +-- analysis state (which may be @top@ or a different value) and +-- something providing a control flow graph, along with the opaque +-- analysis object. The analysis then returns an abstract result that +-- represents dataflow facts at each 'Instruction' in the 'Function'. +-- For example, +-- +-- > let initialState = ... +-- > a = dataflowAnalysis top meet transfer +-- > results = forwardDataflow initialState analysis cfg +-- > in dataflowResult results +-- +-- gives the dataflow value for the virtual exit node (to which all +-- other function termination instructions flow). To get results at +-- other instructions, see 'dataflowResultAt'. +module LLVM.Analysis.Dataflow ( + -- * Dataflow analysis + DataflowAnalysis, + fwdDataflowAnalysis, + bwdDataflowAnalysis, + fwdDataflowEdgeAnalysis, + bwdDataflowEdgeAnalysis, + dataflow, + -- -- * Dataflow results + DataflowResult, + dataflowResult, + dataflowResultAt + ) where + +import LLVM.Analysis.CFG.Internal diff --git a/src/LLVM/Analysis/Dominance.hs b/src/LLVM/Analysis/Dominance.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/Dominance.hs @@ -0,0 +1,274 @@ +-- | Tools to compute dominance information for functions. Includes +-- postdominators. +-- +-- A node @m@ postdominates a node @n@ iff every path from @n@ to +-- @exit@ passes through @m@. +-- +-- This implementation is based on the dominator implementation in fgl, +-- which is based on the algorithm from Cooper, Harvey, and Kennedy: +-- +-- http://www.cs.rice.edu/~keith/Embed/dom.pdf +module LLVM.Analysis.Dominance ( + -- * Types + DominatorTree, + PostdominatorTree, + HasDomTree(..), + HasPostdomTree(..), + -- * Constructors + dominatorTree, + postdominatorTree, + -- * Queries + dominates, + dominators, + dominatorsFor, + immediateDominatorFor, + immediateDominators, + postdominates, + postdominators, + postdominatorsFor, + immediatePostdominatorFor, + immediatePostdominators + ) where + +import Control.Arrow ( (&&&) ) +import qualified Data.Graph.Inductive.Graph as G +import qualified Data.Graph.Inductive.Basic as G +import qualified Data.Graph.Inductive.PatriciaTree as G +import qualified Data.Graph.Inductive.Query.Dominators as G +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IM +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Maybe ( fromMaybe ) +import Data.Monoid +import Data.GraphViz + +import LLVM.Analysis +import LLVM.Analysis.CFG + +-- import qualified Text.PrettyPrint.GenericPretty as PP +-- import Debug.Trace +-- debug = flip trace + +data DominatorTree = DT CFG (Map Instruction Instruction) + +class HasDomTree a where + getDomTree :: a -> DominatorTree + +instance HasDomTree DominatorTree where + getDomTree = id + +-- | Note, this instance constructs the dominator tree and could be +-- expensive +instance HasDomTree CFG where + getDomTree = dominatorTree + +instance HasCFG DominatorTree where + getCFG (DT cfg _) = cfg + +instance HasFunction DominatorTree where + getFunction = getFunction . getCFG + +-- | Construct a DominatorTree from something that behaves like a +-- control flow graph. +dominatorTree :: (HasCFG cfg) => cfg -> DominatorTree +dominatorTree f = DT cfg idomMap + where + cfg = getCFG f + (g, revmap) = cfgToGraph cfg + idoms = G.iDom g (instructionUniqueId entryInst) + idomMap = foldr (remapInst revmap) mempty idoms + -- to make the rooted graph, we don't need any extra nodes here - + -- just pull out the entry instruction + entryBlock : _ = functionBody (getFunction cfg) + entryInst : _ = basicBlockInstructions entryBlock + +immediateDominatorFor :: (HasDomTree t) => t -> Instruction -> Maybe Instruction +immediateDominatorFor dt i = M.lookup i t + where + DT _ t = getDomTree dt + +immediateDominators :: (HasDomTree t) => t -> [(Instruction, Instruction)] +immediateDominators dt = M.toList t + where + DT _ t = getDomTree dt + +-- | Check whether n dominates m +dominates :: (HasDomTree t) => t -> Instruction -> Instruction -> Bool +dominates dt n m = checkDom m + where + (DT _ t) = getDomTree dt + -- Walk backwards in the dominator tree looking for n + checkDom i + | i == n = True + | otherwise = maybe False checkDom (M.lookup i t) + +dominators :: (HasDomTree t) => t -> [(Instruction, [Instruction])] +dominators pt = + zip is (map (getDominators t) is) + where + dt@(DT _ t) = getDomTree pt + f = getFunction dt + is = functionInstructions f + +dominatorsFor :: (HasDomTree t) => t -> Instruction -> [Instruction] +dominatorsFor pt = getDominators t + where + DT _ t = getDomTree pt + + +data PostdominatorTree = PDT CFG (Map Instruction Instruction) + +class HasPostdomTree a where + getPostdomTree :: a -> PostdominatorTree + +-- | Note that this instance constructs the postdominator tree from +-- scratch. +instance HasPostdomTree CFG where + getPostdomTree = postdominatorTree + +instance HasPostdomTree PostdominatorTree where + getPostdomTree = id + +instance HasCFG PostdominatorTree where + getCFG (PDT cfg _) = cfg + +instance HasFunction PostdominatorTree where + getFunction = getFunction . getCFG + +-- | Construct a PostdominatorTree from something that behaves like a +-- control flow graph. +postdominatorTree :: (HasCFG f) => f -> PostdominatorTree +postdominatorTree f = (PDT cfg idomMap) + where + cfg = getCFG f + (g, revmap) = cfgToGraph cfg + idoms = G.iDom (G.grev g) (-1) + idomMap = foldr (remapInst revmap) mempty idoms + -- To make the rooted graph here, we need to add a virtual exit + -- node. Also note that we reverse the edges in the graph because + -- this is a postdominator tree. + +remapInst :: (Ord a) => IntMap a -> (Int, Int) -> Map a a -> Map a a +remapInst revmap (n, d) acc = fromMaybe acc $ do + nI <- IM.lookup n revmap + dI <- IM.lookup d revmap + return $ M.insert nI dI acc + +immediatePostdominatorFor :: (HasPostdomTree t) => t -> Instruction -> Maybe Instruction +immediatePostdominatorFor pt i = M.lookup i t + where + PDT _ t = getPostdomTree pt + +immediatePostdominators :: (HasPostdomTree t) => t -> [(Instruction, Instruction)] +immediatePostdominators pt = M.toList t + where + PDT _ t = getPostdomTree pt + +-- | Tests whether or not an Instruction n postdominates Instruction m +postdominates :: (HasPostdomTree t) => t -> Instruction -> Instruction -> Bool +postdominates pdt n m = checkPDom m + where + PDT _ t = getPostdomTree pdt + checkPDom i + | i == n = True + | otherwise = maybe False checkPDom (M.lookup i t) + +postdominators :: (HasPostdomTree t) => t -> [(Instruction, [Instruction])] +postdominators pt = + zip is (map (getDominators t) is) + where + pdt@(PDT _ t) = getPostdomTree pt + f = getFunction pdt + is = functionInstructions f + +postdominatorsFor :: (HasPostdomTree t) => t -> Instruction -> [Instruction] +postdominatorsFor pt = getDominators t + where + PDT _ t = getPostdomTree pt + +-- | Return the dominators (or postdominators) of the given +-- instruction, in order (with the nearest dominators at the beginning +-- of the list). Note that the instruction iself is not included +-- (every instruction trivially dominates itself). +getDominators :: Map Instruction Instruction + -> Instruction + -> [Instruction] +getDominators m = go + where + go i = + case M.lookup i m of + Nothing -> [] + Just dom -> dom : go dom + +-- Internal + +-- | Convert the nice CFG to a less nice Graph format; this is a +-- linear process. We'll then pass this new graph to dom-lt to +-- compute immediate dominators for us efficiently. +-- +-- IDs will be Instruction UniqueIds, and the root will be the ID of +-- the entry instruction. +cfgToGraph :: CFG -> (G.Gr () (), IntMap Instruction) +cfgToGraph cfg = (G.mkGraph ns es, revMap) + where + f = getFunction cfg + blocks = functionBody f + is = functionInstructions f + revMap = foldr (\i -> IM.insert (instructionUniqueId i) i) mempty is + -- Make sure we add the virtual exit node + ns = (-1, ()) : map (\i -> (instructionUniqueId i, ())) is + es = concatMap (blockEdges cfg) blocks + +-- | Construct all of the edges internal to a basic block, as well as +-- the edges from the terminator instruction to its successors. If +-- the terminator has no successors (it is an exit instruction), give +-- it a virtual edge to -1. +blockEdges :: (HasCFG cfg) => cfg -> BasicBlock -> [(UniqueId, UniqueId, ())] +blockEdges cfg b = + addSuccessorEdges internalEdges + where + mkEdge s d = (s, d, ()) + is = map instructionUniqueId $ basicBlockInstructions b + ti = instructionUniqueId $ basicBlockTerminatorInstruction b + succs = map blockEntryId $ basicBlockSuccessors cfg b + internalEdges = map (\(s, d) -> mkEdge s d) (zip is (tail is)) + -- If we have successors, do the sensible thing. If we don't have + -- successors, add an edge from ti -> -1 (a virtual catchall + -- exit), + addSuccessorEdges a + | null succs = mkEdge ti (-1) : a + | otherwise = map (\sb -> mkEdge ti sb) succs ++ a + +blockEntryId :: BasicBlock -> UniqueId +blockEntryId bb = instructionUniqueId ei + where + ei : _ = basicBlockInstructions bb + + +-- Visualization +domTreeParams :: GraphvizParams n Instruction el () Instruction +domTreeParams = + nonClusteredParams { fmtNode = \(_, l) -> [ toLabel (toValue l) ] } + +treeToGraphviz :: CFG -> Map Instruction Instruction -> DotGraph Int +treeToGraphviz cfg t = graphElemsToDot domTreeParams ns es + where + f = getFunction cfg + is = functionInstructions f + ns = map (instructionUniqueId &&& id) is + es = foldr toDomEdge [] is + + toDomEdge i acc = + case M.lookup i t of + Nothing -> acc + Just d -> + (instructionUniqueId i, instructionUniqueId d, ()) : acc + +instance ToGraphviz DominatorTree where + toGraphviz (DT cfg t) = treeToGraphviz cfg t + +instance ToGraphviz PostdominatorTree where + toGraphviz (PDT cfg t) = treeToGraphviz cfg t + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/src/LLVM/Analysis/NoReturn.hs b/src/LLVM/Analysis/NoReturn.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/NoReturn.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +-- | An analysis to identify functions that never return to their +-- caller. This only counts calls to exit, abort, or similar. +-- Notably, exceptions are not considered since the caller can catch +-- those. +-- +-- The dataflow fact is "Function does not return". It starts at +-- False (top) and calls to termination functions (or the unreachable +-- instruction) move it to True. +-- +-- Meet is &&. Functions are able to return as long as at least one +-- path can return. +module LLVM.Analysis.NoReturn ( + noReturnAnalysis + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.HashSet ( HashSet ) +import qualified Data.HashSet as S + +import LLVM.Analysis +import LLVM.Analysis.CFG +import LLVM.Analysis.Dataflow + +-- | The dataflow fact; Bool is not enough. Top is "NotReturned" - +-- the function has not returned yet. Return instructions will +-- transfer to "Returned". However, we want to distinguish between +-- "Hasn't returned yet" and "Can never return" in case we see a call +-- to a function we know cannot return (but LLVM does not). +-- +-- If LLVM recognizes that something cannot return, it will add an +-- unreachable instruction (from which we also return NeverReturns). +-- +-- If even a single Returned value is incoming to the exit node, the +-- function can return. +data ReturnInfo = NotReturned + | Returned + | WillNeverReturn + deriving (Show, Eq) + +meet :: ReturnInfo -> ReturnInfo -> ReturnInfo +meet Returned _ = Returned +meet _ Returned = Returned +meet WillNeverReturn _ = WillNeverReturn +meet _ WillNeverReturn = WillNeverReturn +meet NotReturned NotReturned = NotReturned + +data AnalysisEnvironment m = + AE { externalSummary :: ExternalFunction -> m Bool + , internalSummary :: HashSet Function + } + +-- | The analysis monad is just a Reader whose environment is a function +-- to test ExternalFunctions +type AnalysisMonad m = ReaderT (AnalysisEnvironment m) m + +-- | The functions in the returned set are those that do not return. +-- +-- Warning, this return type may become abstract at some point. +noReturnAnalysis :: (Monad m, HasCFG cfg) + => (ExternalFunction -> m Bool) + -> cfg + -> HashSet Function + -> m (HashSet Function) +noReturnAnalysis extSummary cfgLike summ = do + let cfg = getCFG cfgLike + f = getFunction cfg + env = AE extSummary summ + analysis = fwdDataflowAnalysis NotReturned meet returnTransfer + localRes <- runReaderT (dataflow cfg analysis NotReturned) env + case dataflowResult localRes of + WillNeverReturn -> return $! S.insert f summ + NotReturned -> return $! S.insert f summ + Returned -> return summ + +returnTransfer :: (Monad m) => ReturnInfo -> Instruction -> AnalysisMonad m ReturnInfo +returnTransfer ri i = + case i of + CallInst { callFunction = calledFunc } -> + dispatchCall ri calledFunc + InvokeInst { invokeFunction = calledFunc } -> + dispatchCall ri calledFunc + UnreachableInst {} -> return WillNeverReturn + ResumeInst {} -> return WillNeverReturn + RetInst {} -> return Returned + _ -> return ri + +dispatchCall :: (Monad m) => ReturnInfo -> Value -> AnalysisMonad m ReturnInfo +dispatchCall ri v = + case valueContent' v of + FunctionC f -> do + intSumm <- asks internalSummary + case S.member f intSumm of + True -> return WillNeverReturn + False -> return ri + ExternalFunctionC ef -> do + extSumm <- asks externalSummary + isNoRet <- lift $ extSumm ef + case isNoRet of + True -> return WillNeverReturn + False -> return ri + _ -> return ri + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/src/LLVM/Analysis/NullPointers.hs b/src/LLVM/Analysis/NullPointers.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/NullPointers.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +-- | An analysis to identify the NULL state of pointers at each +-- Instruction in a Function. Pointers can either be DefiniteNULL, +-- NotNULL, or Unknown. Only DefiniteNULL and NotNULL are recorded - +-- all other pointers are Unknown. +module LLVM.Analysis.NullPointers ( + HasNullSummary(..), + NullPointersSummary, + nullPointersAnalysis, + nullPointersAt, + notNullPointersAt, + branchNullInfo, + NullInfoError(..) + ) where + +import Control.Failure +import Data.Functor.Identity +import Data.Maybe ( fromMaybe ) +import Data.Monoid +import Data.HashSet ( HashSet ) +import qualified Data.HashSet as HS +import Data.Typeable ( Typeable ) + +import LLVM.Analysis +import LLVM.Analysis.CFG +import LLVM.Analysis.Dataflow + +class HasNullSummary a where + getNullSummary :: a -> NullPointersSummary + +instance HasNullSummary NullPointersSummary where + getNullSummary = id + +data NULLState = Top + | NS (HashSet Value) (HashSet Value) + -- ^ Must be NULL, definitely not NULL + deriving (Eq, Show) + +-- | A record of the known NULL and known Not-NULL pointers at each +-- Instruction. +newtype NullPointersSummary = + NPS (DataflowResult Identity NULLState) + deriving (Eq, Show) + +-- | Determine which pointers are NULL and NotNULL at each +-- Instruction. +nullPointersAnalysis :: (HasCFG cfg) => cfg -> NullPointersSummary +nullPointersAnalysis cfgLike = + NPS $ runIdentity $ dataflow cfgLike analysis f0 + where + f0 = NS mempty mempty + + analysis = fwdDataflowEdgeAnalysis Top meet transfer edgeTransfer +-- See Note [NULL Pointers] + +nullPointersAt :: NullPointersSummary -> Instruction -> [Value] +nullPointersAt (NPS summ) i = + case runIdentity $ dataflowResultAt summ i of + Top -> [] + NS mustNull _ -> HS.toList mustNull + +notNullPointersAt :: NullPointersSummary -> Instruction -> [Value] +notNullPointersAt (NPS summ) i = + case runIdentity $ dataflowResultAt summ i of + Top -> [] + NS _ notNull -> HS.toList notNull + +-- | If an item is in must1 and must2, it must be null in the +-- result. Likewise not1 and not2. The intersections are separate and +-- simple. +meet :: NULLState -> NULLState -> NULLState +meet Top other = other +meet other Top = other +meet (NS must1 not1) (NS must2 not2) = + NS (must1 `HS.intersection` must2) (not1 `HS.intersection` not2) + +-- | The transfer function is the identity because all work is done on +-- the edges. +transfer :: (Monad m) => NULLState -> Instruction -> m NULLState +transfer s _ = return s + +-- | If this terminator is a conditional branch comparing a pointer +-- against NULL, propagate the null/notnull info along the appropriate +-- CFG edges. +-- +-- We don't need to be too careful about checking for a==b (where b or +-- a is a pointer known to be NULL) because we can rely on constant +-- propagation from LLVM. +edgeTransfer :: (Monad m ) => NULLState -> Instruction -> m [(BasicBlock, NULLState)] +edgeTransfer s i = return $ fromMaybe [] $ do + (nullBlock, nullVal, notNullBlock) <- branchNullInfo i + return [(nullBlock, addNull nullVal s), + (notNullBlock, addNotNull nullVal s) + ] + +isNullPtr :: Value -> Bool +isNullPtr (valueContent -> ConstantC ConstantPointerNull {}) = True +isNullPtr _ = False + +data NullInfoError = NotABranchInst Instruction + | NotANullTest Instruction + deriving (Typeable, Show) + +-- | Given a BranchInst, return: +-- +-- 1) The BasicBlock where a pointer is known to be NULL +-- +-- 2) The value known to be NULL +-- +-- 3) The BasicBlock where the pointer is known to be not NULL +branchNullInfo :: (Failure NullInfoError m) + => Instruction + -> m (BasicBlock, Value, BasicBlock) +branchNullInfo i@BranchInst { branchTrueTarget = tt + , branchFalseTarget = ft + , branchCondition = (valueContent -> InstructionC ci@ICmpInst { cmpPredicate = ICmpEq }) + } + | isNullPtr (cmpV1 ci) = return (tt, cmpV2 ci, ft) + | isNullPtr (cmpV2 ci) = return (tt, cmpV1 ci, ft) + | otherwise = failure (NotANullTest i) +branchNullInfo i@BranchInst { branchTrueTarget = tt + , branchFalseTarget = ft + , branchCondition = (valueContent -> InstructionC ci@ICmpInst { cmpPredicate = ICmpNe }) + } + | isNullPtr (cmpV1 ci) = return (ft, cmpV2 ci, tt) + | isNullPtr (cmpV2 ci) = return (ft, cmpV1 ci, tt) + | otherwise = failure (NotANullTest i) +branchNullInfo i = failure (NotABranchInst i) + + + +addNull :: Value -> NULLState -> NULLState +addNull v s = + case s of + Top -> NS (HS.singleton v) mempty + NS must notNull -> NS (HS.insert v must) notNull + +addNotNull :: Value -> NULLState -> NULLState +addNotNull v s = + case s of + Top -> NS mempty (HS.singleton v) + NS must notNull -> NS must (HS.insert v notNull) + + +{- Note [NULL Pointers] + +The algorithm proceeds in two simple phases. + +In the first, we check the direct control dependencies for each block. +The terminator instruction for each of these control dependencies +should be a conditional branch. If the condition is a NULL check and +we can determine that the current block is on either the NULL or not +NULL path, we treat that as a fact for the current block. This +produces a map from blocks to known NULL/Not Null states for a given +value. + +We then use this initial map in the dataflow analysis. At every +instruction whose basic block is in the map, introduce the map fact at +that point in the dataflow analysis. It will handle meeting facts and +propagating them across other branches (if possible). + +-} diff --git a/src/LLVM/Analysis/PointsTo.hs b/src/LLVM/Analysis/PointsTo.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/PointsTo.hs @@ -0,0 +1,39 @@ +-- | This module defines the interface to points-to analysis in this +-- analysis framework. Each points-to analysis returns a result +-- object that is an instance of the 'PointsToAnalysis' typeclass; the +-- results are intended to be consumed through this interface. +-- +-- All of the points-to analysis implementations expose a single function: +-- +-- > runPointsToAnalysis :: (PointsToAnalysis a) => Module -> a +-- +-- This makes it easy to change the points-to analysis you are using: +-- just modify your imports. If you need multiple points-to analyses +-- in the same module (for example, to support command-line selectable +-- points-to analysis precision), use qualified imports. +module LLVM.Analysis.PointsTo ( + -- * Classes + PointsToAnalysis(..), + ) where + +import LLVM.Analysis + +-- | The interface to any points-to analysis. +class PointsToAnalysis a where + mayAlias :: a -> Value -> Value -> Bool + -- ^ Check whether or not two values may alias + pointsTo :: a -> Value -> [Value] + -- ^ Return the list of values that a LoadInst may return. May + -- return targets for other values too (e.g., say that a Function + -- points to itself), but nothing is guaranteed. + -- + -- Should also give reasonable answers for globals and arguments + resolveIndirectCall :: a -> Instruction -> [Value] + -- ^ Given a Call instruction, determine its possible callees. The + -- default implementation just delegates the called function value + -- to 'pointsTo' and . + resolveIndirectCall pta i = + case i of + CallInst { callFunction = f } -> pointsTo pta f + InvokeInst { invokeFunction = f } -> pointsTo pta f + _ -> [] diff --git a/src/LLVM/Analysis/PointsTo/AllocatorProfile.hs b/src/LLVM/Analysis/PointsTo/AllocatorProfile.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/PointsTo/AllocatorProfile.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module defines a number of allocation profiles that are +-- meant to be inputs to the points-to analyses. These profiles +-- identify the set of instructions that allocate *fresh* memory +-- locations (e.g., @malloc@). +-- +-- Different profiles are useful for different languages or setups. +-- The points-to analyses take lists of these functions so they can be +-- combined arbitrarily (and augmented with user-provided versions). +module LLVM.Analysis.PointsTo.AllocatorProfile ( + standardCProfile + ) where + +import LLVM.Analysis + +-- | This profile corresponds to the standard C library and marks +-- @malloc@, @calloc@, and @alloca@ as allocators. @realloc@ is not +-- always an allocator (since it could return existing memory), so it +-- is not included. +-- +-- This function returns True if the given instruction must be a call +-- to a standard C library allocation function. +standardCProfile :: Instruction -> Bool +standardCProfile CallInst { callFunction = cf } = + case valueContent cf of + ExternalFunctionC ef -> + let ident = identifierContent (externalFunctionName ef) + in ident == "malloc" || ident == "calloc" || ident == "alloca" + _ -> False +standardCProfile _ = False diff --git a/src/LLVM/Analysis/PointsTo/Andersen.hs b/src/LLVM/Analysis/PointsTo/Andersen.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/PointsTo/Andersen.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE ViewPatterns, DeriveDataTypeable, CPP #-} +-- | This is a simple implementation of Andersen's points-to analysis. +-- +-- TODO: +-- +-- * Add field sensitivity eventually. See http://delivery.acm.org/10.1145/1300000/1290524/a4-pearce.pdf?ip=128.105.181.27&acc=ACTIVE%20SERVICE&CFID=52054919&CFTOKEN=71981976&__acm__=1320350342_65be4c25a6fba7e32d7b4cd60f13fe97 +module LLVM.Analysis.PointsTo.Andersen ( + -- * Types + Andersen, + -- * Constructor + runPointsToAnalysis, + runPointsToAnalysisWith + ) where + +import Control.Exception +import Control.Monad ( foldM ) +import Control.Monad.Trans.State.Strict +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Text ( Text, pack ) +import Data.Typeable + +import LLVM.Analysis +import LLVM.Analysis.PointsTo + +import Constraints.Set.Solver +-- import Constraints.Set.Internal + +#if defined(DEBUGCONSTRAINTS) +import Debug.Trace +#endif + +-- A monad to manage fresh variable generation +data ConstraintState = ConstraintState { freshIdSrc :: !Int } +type ConstraintGen = State ConstraintState + +freshVariable :: ConstraintGen SetExp +freshVariable = do + s <- get + let vid = freshIdSrc s + v = Fresh vid + put $ s { freshIdSrc = vid + 1 } + return $! setVariable v + + +data Constructor = Ref + | Atom !Value + deriving (Eq, Ord, Show, Typeable) + +data Var = Fresh !Int + | LocationSet !Value -- The X_{l_i} variables + | LoadedLocation !Instruction + | ArgLocation !Argument + | VirtualArg !Value !Int + | VirtualFieldArg !Type !Int !Int + | RetLocation !Instruction + | GEPLocation !Value + | PhiCopy !Instruction + | FieldLoc Text {-!Type-} !Int + deriving (Eq, Ord, Show, Typeable) + +type SetExp = SetExpression Var Constructor +data Andersen = Andersen !(SolvedSystem Var Constructor) + +instance PointsToAnalysis Andersen where + mayAlias = andersenMayAlias + pointsTo = andersenPointsTo + +andersenMayAlias :: Andersen -> Value -> Value -> Bool +andersenMayAlias _ _ _ = True + +andersenPointsTo :: Andersen -> Value -> [Value] +andersenPointsTo (Andersen ss) v = + either fromError (map fromLocation) (leastSolution ss var) + where + var = case valueContent' v of + ArgumentC a -> ArgLocation a + InstructionC i@CallInst {} -> RetLocation i + InstructionC i@InvokeInst {} -> RetLocation i + InstructionC i@LoadInst {} -> LoadedLocation i + InstructionC i@SelectInst {} -> PhiCopy i + InstructionC i@PhiNode {} -> PhiCopy i + InstructionC GetElementPtrInst { getElementPtrValue = base } -> + -- should be a FieldLoc + GEPLocation (getTargetIfLoad base) + _ -> LocationSet v + fromError :: ConstraintError Var Constructor -> [Value] + fromError = const [] + fromLocation :: SetExp -> Value + fromLocation (ConstructedTerm Ref _ [ConstructedTerm (Atom val) _ _, _, _]) = val + fromLocation se = error ("Unexpected set expression in result " ++ show se) + +runPointsToAnalysis :: Module -> Andersen +runPointsToAnalysis = runPointsToAnalysisWith (const False) + +runPointsToAnalysisWith :: (Value -> Bool) -> Module -> Andersen +runPointsToAnalysisWith ignore m = evalState (pta ignore m) (ConstraintState 0) + +-- For any load of a field access (or perhaps any field GEP), add an +-- inclusion that maps it to the virtual ? + +-- | Generate constraints and solve the system. Any system we +-- generate should be solvable if we are generating the correct +-- constraints, so convert solving failures into an IO exception. +pta :: (Value -> Bool) -> Module -> ConstraintGen Andersen +pta ignore m = do + initConstraints <- foldM globalInitializerConstraints [] (moduleGlobalVariables m) + funcConstraints <- foldM functionConstraints [] (moduleDefinedFunctions m) + let is = initConstraints ++ funcConstraints + sol = either throwErr id (solveSystem is) + return $! Andersen sol + where + loadVar ldInst = setVariable (LoadedLocation ldInst) + argVar a = setVariable (ArgLocation a) + phiVar i = setVariable (PhiCopy i) + gepVar v = setVariable (GEPLocation v) + + -- If the location the function pointer is being stored to is a + -- struct field, we need a special virtual argument that + -- references the struct field instead of the value (because + -- struct fields are treated differently from other values - every + -- instance of a struct field maps to the same struct field slot + -- indexed by type/position). + virtArgVar sa ix = + case valueContent' sa of + InstructionC GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = ixs + } -> + case fieldDescriptor base ixs of + Just (t, fldno) -> setVariable (VirtualFieldArg t fldno ix) + Nothing -> setVariable (VirtualArg sa ix) + _ -> setVariable (VirtualArg sa ix) + returnVar i = setVariable (RetLocation i) + ref = term Ref [Covariant, Covariant, Contravariant] + loc val = + let svar = fromMaybe (setVariable (LocationSet val)) (setVarFor val) + in ref [ atom (Atom val), svar, svar ] + + -- FIXME Test taking and storing the address of a field (and then + -- using it) + -- + -- Also test embedded structs. Include some interspersed arrays? + -- + -- Test funcptrs stored in an array (all should match on call) + -- Still need a few more. + + setVarFor v = + case valueContent' v of + InstructionC i@LoadInst {} -> return $ loadVar i + InstructionC i@CallInst {} -> return $ returnVar i + InstructionC i@InvokeInst {} -> return $ returnVar i + InstructionC i@PhiNode {} -> return $ phiVar i + InstructionC i@SelectInst {} -> return $ phiVar i + InstructionC GetElementPtrInst { getElementPtrValue = base } -> + return $ gepVar (getTargetIfLoad base) + ArgumentC a -> return $ argVar a + _ -> Nothing + + -- Have to be careful handling phi nodes - those will actually need to + -- generate many constraints, and the rule for each one can generate a + -- new set of assignments. + setExpFor v = + case valueContent' v of + InstructionC GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = ixs + } -> + case fieldDescriptor base ixs of + -- If we couldn't compute a field descriptor, this is an + -- array. + Nothing -> gepVar (getTargetIfLoad base) + -- If this is a field access, treat it as the location for + -- all slots of the given index in that type (one slot for + -- all instances). + Just (t, ix) -> + let var = setVariable (FieldLoc (pack (show t)) ix) + in ref [ atom (Atom v), var, var ] + -- This case is a bit of a hack to deal with the conversion from + -- an array type to a pointer to the first element (using a + -- constant GEP with all zero indices). + ConstantC ConstantValue { constantInstruction = (valueContent' -> + InstructionC GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = is + })} -> + case valueType base of + TypePointer (TypeArray _ _) _ -> + case all isConstantZero is of + True -> setVariable (LocationSet base) + False -> loc v + _ -> + case fieldDescriptor base is of + Nothing -> gepVar (getTargetIfLoad base) + Just (t, ix) -> + let var = setVariable (FieldLoc (pack (show t)) ix) + in ref [ atom (Atom v), var, var ] + _ -> fromMaybe (loc v) (setVarFor v) + + -- FIXME This probably needs to use the type of the initializer to + -- determine if the initializer is a copy of another global or an + -- address to a specific location + globalInitializerConstraints acc global = + case globalVariableInitializer global of + Nothing -> return acc + Just (valueContent -> ConstantC _) -> return acc + Just i -> do + f1 <- freshVariable + f2 <- freshVariable + let c1 = loc (toValue global) <=! ref [ universalSet, universalSet, f1 ] + c2 = ref [ emptySet, loc i, emptySet ] <=! ref [ universalSet, f2, emptySet ] + c3 = f2 <=! f1 + return $ c1 : c2 : c3 : acc + + functionConstraints acc = foldM instructionConstraints acc . functionInstructions + instructionConstraints acc i = + case i of + LoadInst { loadAddress = la } + | ignore la -> return acc + | otherwise -> do + -- If we load a function pointer, add new virtual nodes and + -- link them up + let c = setExpFor la <=! ref [ universalSet, loadVar i, emptySet ] + acc' <- addVirtualConstraints acc (toValue i) la + return $ c : acc' `traceConstraints` ("Inst: " ++ show i, [c]) + + -- If you store the stored address is a function type, add + -- inclusion edges between the virtual arguments. If sv is a + -- Function, add virtual args linked to formals. + StoreInst { storeAddress = sa, storeValue = sv } + | ignore sa || ignore sv -> return acc + | otherwise -> do + f1 <- freshVariable + f2 <- freshVariable + let c1 = setExpFor sa <=! ref [ universalSet, universalSet, f1 ] + c2 = ref [ emptySet, setExpFor sv, emptySet ] <=! ref [ universalSet, f2, emptySet ] + c3 = f2 <=! f1 + acc' <- addVirtualConstraints acc sa sv + return $ c1 : c2 : c3 : acc' `traceConstraints` ("Inst: " ++ show i, [c1,c2,c3]) + + CallInst { callFunction = (valueContent' -> FunctionC f) + , callArguments = (map fst -> args) + } -> directCallConstraints acc i f args + InvokeInst { invokeFunction = (valueContent' -> FunctionC f) + , invokeArguments = (map fst -> args) + } -> directCallConstraints acc i f args + -- For now, don't model calls to external functions + CallInst { callFunction = (valueContent' -> ExternalFunctionC _) } -> + return acc + InvokeInst { invokeFunction = (valueContent' -> ExternalFunctionC _) } -> + return acc + CallInst { callFunction = callee, callArguments = (map fst -> args) } -> + indirectCallConstraints acc callee args + InvokeInst { invokeFunction = callee, invokeArguments = (map fst -> args) } -> + indirectCallConstraints acc callee args + + SelectInst { selectTrueValue = tv, selectFalseValue = fv } -> + foldM (valueAliasingChoise i) acc [ tv, fv ] + PhiNode { phiIncomingValues = ivs } -> + foldM (valueAliasingChoise i) acc (map fst ivs) + + -- FIXME: Add a case handling bitcasts. If one type is + -- bitcast to a related type, add equivalences between all of + -- their respective fields. Relation is by structural + -- subtyping. + + -- Array rule. Equate the base of the GEP and the GEP, + -- effectively treating every array element as one location. + -- This particular rule deals with pointers that are treated + -- as arrays (the GEP has only one index). + -- + -- Note that this rule looks into the base of the GEP deeply + -- and is not totally local. This seemed necessary to hook + -- the constraints into the proper place in the constraint + -- graph. It may be possible to keep it entirely local with + -- extra variables as is done for function pointers. + GetElementPtrInst { getElementPtrValue = (valueContent' -> + InstructionC LoadInst { loadAddress = la }) + , getElementPtrIndices = [_] + } + | ignore la || ignore (toValue i) -> return acc + | otherwise -> do + f1 <- freshVariable + f2 <- freshVariable + + let c1 = loc (toValue i) <=! ref [ universalSet, universalSet, f1 ] + c2 = ref [ emptySet, setExpFor la, emptySet ] <=! ref [ universalSet, f2, emptySet ] + c3 = f2 <=! f1 + + acc' <- addVirtualConstraints acc (toValue i) la + return $ c1 : c2 : c3 : acc' `traceConstraints` (concat ["GEP: " ++ show i], [c1,c2,c3]) + + GetElementPtrInst { getElementPtrValue = base + , getElementPtrIndices = [_] + } + | ignore base || ignore (toValue i) -> return acc + | otherwise -> do + f1 <- freshVariable + f2 <- freshVariable + + let c1 = loc (toValue i) <=! ref [ universalSet, universalSet, f1 ] + c2 = ref [ emptySet, loc base, emptySet ] <=! ref [ universalSet, f2, emptySet ] + c3 = f2 <=! f1 + + acc' <- addVirtualConstraints acc (toValue i) base + return $ c1 : c2 : c3 : acc' `traceConstraints` (concat ["GEP: " ++ show i], [c1,c2,c3]) + + GetElementPtrInst { getElementPtrValue = base, + getElementPtrIndices = [(valueContent -> ConstantC ConstantInt { constantIntValue = 0 }) + , _ + ] + } -> + case valueType base of + TypePointer (TypeArray _ _) _ -> do + f1 <- freshVariable + f2 <- freshVariable + + let c1 = loc (toValue i) <=! ref [ universalSet, universalSet, f1 ] + c2 = ref [ emptySet, setExpFor base, emptySet ] <=! ref [ universalSet, f2, emptySet ] + c3 = f2 <=! f1 + + acc' <- addVirtualConstraints acc (toValue i) base + return $ c1 : c2 : c3 : acc' `traceConstraints` (concat ["GEP: " ++ show i], [c1,c2,c3]) + + -- This case is actually a struct field reference, so fill + -- that in later + _ -> return acc + + _ -> return acc + + directCallConstraints acc i f actuals = do + let formals = functionParameters f + acc' <- foldM copyActualToFormal acc (zip actuals formals) + case valueType i of + TypePointer _ _ | not (ignore (toValue i)) -> do + let rvs = mapMaybe extractRetVal (functionExitInstructions f) + cs <- foldM (retConstraint i) [] rvs + return $ cs ++ acc' + _ -> return acc' + + -- FIXME try adding virtual array constraints that are propagated + -- everywhere; the base one should probably refer to the thing + -- that is an array. This might let us avoid extra cases and + -- treat GEP instructions individually again. If it works, it should + -- also fix test case store-ptr-to-arg-array.c + + addVirtualConstraints acc0 dst src = do + acc1 <- addVirtualArgConstraints acc0 dst src +-- acc2 <- addArrayConstraints acc1 dst src + return acc1 + + -- addArrayConstraints acc dst src = do + -- let c = arrayVar dst <=! arrayVar src + -- return $ c : acc `traceConstraints` (concat ["ArrayVar: ", show src, " -> ", show dst], [c]) + + addVirtualArgConstraints acc sa sv + | not (isFuncPtrType (valueType sv)) = return acc + | otherwise = + case valueContent' sv of + -- Connect the virtuals for sa to the actuals of f + FunctionC f -> do + let formals = functionParameters f + foldM (constrainVirtualArg sa) acc (zip [0..] formals) + -- Otherwise, copy virtuals from old ref to new ref + _ -> do + let nparams = functionTypeParameters (valueType sv) + foldM (virtVirtArg sa sv) acc [0..(nparams - 1)] + + virtVirtArg sa sv acc ix = do + let c1 = virtArgVar sa ix <=! virtArgVar sv ix + c2 = virtArgVar sv ix <=! virtArgVar sa ix + return $ c1 : c2 : acc `traceConstraints` (concat ["VirtVirt: ", show ix, "(", show sa, " -> ", show sv, ")"], [c1, c2]) + + constrainVirtualArg sa acc (ix, frml) = do + let c = virtArgVar sa ix <=! argVar frml + return $ c : acc `traceConstraints` (concat ["VirtArg: ", show ix, "(", show sa, ")"], [c]) + + + -- The idea here will be that we equate the actuals with virtual + -- nodes for this function pointer. For function pointer will + -- always be a load node so we can treat it somewhat uniformly. + -- This may get complicated for loads of fields, but we should be + -- able to take care of that outside of this rule. Globals and + -- locals are easy. + indirectCallConstraints acc callee actuals = do + let addIndirectConstraint (ix, act) a = + if ignore act then a + else let c = setExpFor act <=! virtArgVar callee ix + in c : a `traceConstraints` (concat ["IndirectCall ", show ix, "(", show act, ")" ], [c]) + acc' = foldr addIndirectConstraint acc (zip [0..] actuals) + return acc' + + -- Set up constraints to propagate return values to caller + -- contexts (including function argument virtuals for function + -- pointer types). + retConstraint i acc rv + | ignore rv = return acc + | otherwise = do + let c = setExpFor rv <=! setExpFor (toValue i) + acc' <- addVirtualConstraints acc (toValue i) rv + return $ c : acc' `traceConstraints` (concat [ "RetVal ", show i ], [c]) + + -- Note the rule has to be a bit strange because the formal is an + -- r-value (and not an l-value like everything else). We can + -- actually do the really simple thing from other formulations + -- here because of this. + -- + -- If the actual is a function (pointer) type, also add new + -- virtual arg nodes for the formal + copyActualToFormal acc (act, frml) + | ignore act = return acc + | otherwise = do + let c = setExpFor act <=! argVar frml + acc' <- addVirtualConstraints acc (toValue frml) act + return $ c : acc' `traceConstraints` (concat [ "Args ", show act, " -> ", show frml ], [c]) + + valueAliasingChoise i acc vfrom + | ignore (toValue i) = return acc + | otherwise = do + let c = setExpFor vfrom <=! setExpFor (toValue i) + acc' <- addVirtualConstraints acc (toValue i) vfrom + return $ c : acc' `traceConstraints` (concat [ "MultCopy ", show (valueName vfrom), " -> ", show (valueName i)], [c]) + +-- | Return the innermost type and the index into that type accessed +-- by the GEP instruction with the given base and indices. +fieldDescriptor :: Value -> [Value] -> Maybe (Type, Int) +fieldDescriptor base ixs = + case (valueType base, ixs) of + -- A pointer being accessed as an array + (_, [_]) -> Nothing + -- An actual array type (first index should be zero here) + (TypePointer (TypeArray _ _) _, (valueContent' -> ConstantC ConstantInt { constantIntValue = 0 }):_) -> + Nothing + -- It doesn't matter what the first index is; even if it isn't + -- zero (as in it *is* an array access), we only care about the + -- ultimate field access and not the array. Raw arrays are taken + -- care of above. + (TypePointer t _, _:rest) -> return $ walkType t rest + _ -> Nothing + +walkType :: Type -> [Value] -> (Type, Int) +walkType t [] = error ("LLVM.Analysis.PointsTo.Andersen.walkType: expected non-empty index list for " ++ show t) +walkType t [(valueContent -> ConstantC ConstantInt { constantIntValue = iv })] = + (t, fromIntegral iv) +walkType t (ix:ixs) = + case t of + -- We can ignore inner array indices since we only care about the + -- terminal struct index. Note that if there are no further + -- struct types (e.g., this is an array member of a struct), we + -- need to return the index of the array... FIXME + TypeArray _ t' -> walkType t' ixs + TypeStruct _ ts _ -> + case valueContent ix of + ConstantC ConstantInt { constantIntValue = (fromIntegral -> iv) } -> + case iv < length ts of + True -> walkType (ts !! iv) ixs + False -> error ("LLVM.Analysis.PointsTo.Andersen.walkType: index out of range " ++ show iv ++ " in " ++ show t) + _ -> error ("LLVM.Analysis.PointsTo.Andersen.walkType: non-constant index " ++ show ix ++ " in " ++ show t) + _ -> error ("LLVM.Analysis.PointsTo.Andersen.walkType: unexpected type " ++ show ix ++ " in " ++ show t) + +isConstantZero :: Value -> Bool +isConstantZero v = + case valueContent' v of + ConstantC ConstantInt { constantIntValue = 0 } -> True + _ -> False + +getTargetIfLoad :: Value -> Value +getTargetIfLoad v = + case valueContent' v of + InstructionC LoadInst { loadAddress = la } -> la + _ -> v + +-- TODO: +-- +-- * extra function pointer indirections + +-- Helpers + +{-# INLINE traceConstraints #-} +-- | This is a debugging helper to trace the constraints that are +-- generated. When debugging is disabled via cabal, it is a no-op. +traceConstraints :: a -> (String, [Inclusion Var Constructor]) -> a +#if defined(DEBUGCONSTRAINTS) +traceConstraints a (msg, cs) = trace (msg ++ "\n" ++ (unlines $ map ((" "++) . show) cs)) a +#else +traceConstraints = const +#endif + +isFuncPtrType :: Type -> Bool +isFuncPtrType t = + case t of + TypeFunction _ _ _ -> True + TypePointer t' _ -> isFuncPtrType t' + _ -> False + +functionTypeParameters :: Type -> Int +functionTypeParameters t = + case t of + TypeFunction _ ts _ -> length ts + TypePointer t' _ -> functionTypeParameters t' + _ -> -1 + +extractRetVal :: Instruction -> Maybe Value +extractRetVal RetInst { retInstValue = rv } = rv +extractRetVal _ = Nothing + +throwErr :: ConstraintError Var Constructor -> SolvedSystem Var Constructor +throwErr = throw + +-- Debugging + +{- +instance ToGraphviz Andersen where + toGraphviz = andersenConstraintGraph + +andersenConstraintGraph :: Andersen -> DotGraph Int +andersenConstraintGraph (Andersen s) = + let (ns, es) = solvedSystemGraphElems s + in graphElemsToDot andersenParams ns es + +andersenParams :: GraphvizParams Int (SetExpression Var Constructor) ConstraintEdge () (SetExpression Var Constructor) +andersenParams = defaultParams { isDirected = True + , fmtNode = fmtAndersenNode + , fmtEdge = fmtAndersenEdge + } + +fmtAndersenNode :: (a, SetExpression Var Constructor) -> [Attribute] +fmtAndersenNode (_, l) = + case l of + EmptySet -> [toLabel (show l)] + UniversalSet -> [toLabel (show l)] + SetVariable (FieldLoc t ix) -> + [toLabel ("Field_" ++ unpack t ++ "<" ++ show ix ++ ">")] + SetVariable (Fresh i) -> [toLabel ("F" ++ show i)] + SetVariable (PhiCopy i) -> [toLabel ("PhiCopy " ++ show i)] + SetVariable (GEPLocation i) -> [toLabel ("GEPLoc " ++ show i)] + SetVariable (VirtualArg sa ix) -> + [toLabel ("VA_" ++ show ix ++ "[" ++ show (valueName sa) ++ "]")] + SetVariable (VirtualFieldArg t fld ix) -> + [toLabel ("VAField_" ++ show ix ++ "[" ++ show t ++ ".<" ++ show fld ++ ">]")] + SetVariable (LocationSet v) -> + case valueName v of + Nothing -> [toLabel ("X_" ++ show v)] + Just vn -> [toLabel ("X_" ++ identifierAsString vn)] + SetVariable (ArgLocation a) -> + [toLabel ("AL_" ++ show (argumentName a))] + SetVariable (RetLocation i) -> + [toLabel ("RV_" ++ show (valueName (callFunction i)))] + SetVariable (LoadedLocation i) -> + case valueName i of + Nothing -> error "Loads should have names" + Just ln -> [toLabel ("LL_" ++ identifierAsString ln)] + ConstructedTerm Ref _ [ConstructedTerm (Atom v) _ _, _, _] -> + let vn = maybe (show v) identifierAsString (valueName v) + in [toLabel $ concat [ "Ref( l_", vn, ", X_", vn, ", X_", vn ]] + ConstructedTerm (Atom a) _ _ -> + [toLabel (show a)] + ConstructedTerm _ _ _ -> [toLabel (show l)] + +fmtAndersenEdge :: (a, a, ConstraintEdge) -> [Attribute] +fmtAndersenEdge (_, _, lbl) = + case lbl of + Succ -> [style solid] + Pred -> [style dashed] +-} diff --git a/src/LLVM/Analysis/PointsTo/TrivialFunction.hs b/src/LLVM/Analysis/PointsTo/TrivialFunction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/PointsTo/TrivialFunction.hs @@ -0,0 +1,75 @@ +-- | This module implements a trivial points-to analysis that is +-- intended only for fast conservative callgraph construction. All +-- function pointers can point to all functions with compatible types. +-- +-- Other pointers are considered to alias if they are of the same +-- type. The 'pointsTo' function only returns empty sets for +-- non-function pointers. +module LLVM.Analysis.PointsTo.TrivialFunction ( + -- * Types + TrivialFunction, + -- * Constructor + runPointsToAnalysis + ) where + +import Data.HashMap.Strict ( HashMap ) +import Data.Set ( Set ) +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S + +import LLVM.Analysis +import LLVM.Analysis.PointsTo + +-- | The result of the TrivialFunction points-to analysis. It is an +-- instance of the 'PointsToAnalysis' typeclass and is intended to be +-- queried through that interface. +-- +-- Again, note that this analysis is not precise (just fast) and does +-- not provide points-to sets for non-function types. It provides +-- only type-based answers and does not respect typecasts at all. +newtype TrivialFunction = TrivialFunction (HashMap Type (Set Value)) + +instance PointsToAnalysis TrivialFunction where + mayAlias = trivialMayAlias + pointsTo = trivialPointsTo + +-- | Run the points-to analysis and return its results in an opaque +-- handle. +runPointsToAnalysis :: Module -> TrivialFunction +runPointsToAnalysis m = TrivialFunction finalMap + where + externMap = foldr buildMap M.empty (moduleExternalFunctions m) + finalMap = foldr buildMap externMap (moduleDefinedFunctions m) + +-- | Add function-typed values to the result map. +buildMap :: (IsValue a) => a -> HashMap Type (Set Value) -> HashMap Type (Set Value) +buildMap v = + M.insertWith S.union vtype (S.singleton (toValue v)) + where + vtype = valueType v + +trivialMayAlias :: TrivialFunction -> Value -> Value -> Bool +trivialMayAlias _ v1 v2 = valueType v1 == valueType v2 + +-- Note, don't use the bitcast stripping functions here since we need +-- the surface types of functions. This affects cases where function +-- pointers are stored generically in a struct and then taken out and +-- casted back to their original type. +trivialPointsTo :: TrivialFunction -> Value -> [Value] +trivialPointsTo p@(TrivialFunction m) v = + case valueContent v of + FunctionC _ -> [v] + ExternalFunctionC _ -> [v] + GlobalAliasC ga -> trivialPointsTo p (toValue ga) + InstructionC BitcastInst { castedValue = c } -> + case valueContent c of + FunctionC _ -> trivialPointsTo p c + ExternalFunctionC _ -> trivialPointsTo p c + GlobalAliasC _ -> trivialPointsTo p c + _ -> S.toList $ M.lookupDefault S.empty (derefPointer v) m + _ -> S.toList $ M.lookupDefault S.empty (derefPointer v) m + +derefPointer :: Value -> Type +derefPointer v = case valueType v of + TypePointer p _ -> p + _ -> error ("LLVM.Analysis.PointsTo.TrivialPointer.derefPointer: Non-pointer type given to trivalPointsTo: " ++ show v) diff --git a/src/LLVM/Analysis/ScalarEffects.hs b/src/LLVM/Analysis/ScalarEffects.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/ScalarEffects.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-} +{-| + +This analysis identifies the (memory) effects that functions have on +the scalar components of their arguments. + +Only pointer parameters are interesting because only their effects can +escape the callee. Effects are currently restricted to increments and +decrements of integral types. The affected memory can be a struct +member; the effects are described in terms of abstract AccessPaths. + +This is a must analysis. Effects are only reported if they *MUST* +occur (modulo non-termination style effects like calls to exit or +infinite loops). + +Currently, sequential effects are not composed and nothing useful will +be reported. + +-} +module LLVM.Analysis.ScalarEffects ( + ScalarEffectResult, + ScalarEffect(..), + scalarEffectAnalysis + ) where + +import Control.DeepSeq +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as HM + +import LLVM.Analysis +import LLVM.Analysis.AccessPath +import LLVM.Analysis.CFG +import LLVM.Analysis.Dataflow + +-- | The types of effects tracked by this analysis. This can be expanded +-- as the analysis becomes more sophisticated (it could include general +-- affine relations or even relate arguments to each other). +data ScalarEffect = EffectAdd1 AbstractAccessPath + | EffectSub1 AbstractAccessPath + deriving (Eq) + +instance NFData ScalarEffect where + rnf e@(EffectAdd1 ap) = ap `deepseq` e `seq` () + rnf e@(EffectSub1 ap) = ap `deepseq` e `seq` () + +type ScalarEffectResult = HashMap Argument ScalarEffect + +data ScalarInfo = SI (HashMap Argument (Maybe ScalarEffect)) + | SITop + +instance Eq ScalarInfo where + (SI s1) == (SI s2) = s1 == s2 + SITop == SITop = True + _ == _ = False + +meet :: ScalarInfo -> ScalarInfo -> ScalarInfo +meet SITop s = s +meet s SITop = s +meet (SI s1) (SI s2) = SI (HM.unionWith mergeEffect s1 s2) + where + -- | If there is an entry in both maps, it must be the same to be + -- retained. + mergeEffect e1 e2 = if e1 == e2 then e1 else Nothing + +-- For each function, initialize all arguments to Nothing +scalarEffectAnalysis :: (Monad m, HasCFG funcLike, HasFunction funcLike) + => funcLike + -> ScalarEffectResult + -> m ScalarEffectResult +scalarEffectAnalysis funcLike summ = do + let cfg = getCFG funcLike + analysis = fwdDataflowAnalysis SITop meet scalarTransfer + + localRes <- dataflow cfg analysis SITop + let xi = case dataflowResult localRes of + SITop -> HM.empty + SI m -> HM.foldlWithKey' discardNothings HM.empty m + return $! HM.union xi summ + +discardNothings :: HashMap Argument ScalarEffect + -> Argument + -> Maybe ScalarEffect + -> HashMap Argument ScalarEffect +discardNothings acc _ Nothing = acc +discardNothings acc a (Just e) = HM.insert a e acc + +scalarTransfer :: (Monad m) => ScalarInfo -> Instruction -> m ScalarInfo +scalarTransfer si i = + case i of + AtomicRMWInst { atomicRMWOperation = AOAdd + , atomicRMWValue = + (valueContent -> ConstantC ConstantInt { constantIntValue = 1 })} -> + recordIfAffectsArgument EffectAdd1 i si + AtomicRMWInst { atomicRMWOperation = AOAdd + , atomicRMWValue = + (valueContent -> ConstantC ConstantInt { constantIntValue = -1 })} -> + recordIfAffectsArgument EffectSub1 i si + AtomicRMWInst { atomicRMWOperation = AOSub + , atomicRMWValue = + (valueContent -> ConstantC ConstantInt { constantIntValue = 1 })} -> + recordIfAffectsArgument EffectSub1 i si + AtomicRMWInst { atomicRMWOperation = AOSub + , atomicRMWValue = + (valueContent -> ConstantC ConstantInt { constantIntValue = -1 })} -> + recordIfAffectsArgument EffectAdd1 i si + StoreInst { storeAddress = sa, storeValue = sv } -> + case isNonAtomicAdd sa sv of + False -> + case isNonAtomicSub sa sv of + False -> return si + True -> recordIfAffectsArgument EffectSub1 i si + True -> recordIfAffectsArgument EffectAdd1 i si + _ -> return si + +isNonAtomicSub :: (IsValue a) => Value -> a -> Bool +isNonAtomicSub sa sv = + case valueContent sv of + InstructionC AddInst { + binaryLhs = (valueContent -> ConstantC ConstantInt { constantIntValue = -1 }), + binaryRhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + InstructionC AddInst { + binaryRhs = (valueContent -> ConstantC ConstantInt { constantIntValue = -1 }), + binaryLhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + InstructionC SubInst { + binaryRhs = (valueContent -> ConstantC ConstantInt { constantIntValue = 1 }), + binaryLhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + _ -> False + +isNonAtomicAdd :: (IsValue a) => Value -> a -> Bool +isNonAtomicAdd sa sv = + case valueContent sv of + InstructionC AddInst { + binaryLhs = (valueContent -> ConstantC ConstantInt { constantIntValue = 1 }), + binaryRhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + InstructionC AddInst { + binaryRhs = (valueContent -> ConstantC ConstantInt { constantIntValue = 1 }), + binaryLhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + InstructionC SubInst { + binaryRhs = (valueContent -> ConstantC ConstantInt { constantIntValue = -1 }), + binaryLhs = (valueContent -> InstructionC LoadInst { loadAddress = la }) } -> + sa == la + _ -> False + +recordIfAffectsArgument :: (Monad m) + => (AbstractAccessPath -> ScalarEffect) + -> Instruction + -> ScalarInfo + -> m ScalarInfo +recordIfAffectsArgument con i si = + case accessPath i of + Nothing -> return si + Just cap -> + case valueContent' (accessPathBaseValue cap) of + ArgumentC a -> + let e = Just $ con (abstractAccessPath cap) + in case si of + SITop -> return $! SI $ HM.insert a e HM.empty + SI m -> return $! SI $ HM.insert a e m + _ -> return si + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/src/LLVM/Analysis/UsesOf.hs b/src/LLVM/Analysis/UsesOf.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/UsesOf.hs @@ -0,0 +1,42 @@ +module LLVM.Analysis.UsesOf ( + UseSummary, + computeUsesOf, + usedBy + ) where + +import qualified Data.Foldable as F +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Maybe ( fromMaybe ) + +import LLVM.Analysis + +data UseSummary = UseSummary (HashMap Value [Instruction]) + +-- | Compute the uses of every value in the 'Module' +-- +-- This information can be used to answer the query: +-- +-- > usedBy useSummary foo +-- +-- which will return all of the Instructions that reference +-- the provided value @foo@. +-- +-- Note that this is a simple index. It does not look through bitcasts +-- at all. +computeUsesOf :: Module -> UseSummary +computeUsesOf m = UseSummary $ fmap HS.toList uses + where + uses = F.foldl' funcUses HM.empty fs + fs = moduleDefinedFunctions m + funcUses acc f = F.foldl' addInstUses acc (functionInstructions f) + addInstUses acc i = F.foldl' (addUses i) acc (instructionOperands i) + addUses i acc v = HM.insertWith HS.union v (HS.singleton i) acc + +-- | > usedBy summ val +-- +-- Find the instructions using @val@ in the function that @summ@ was +-- computed for. +usedBy :: UseSummary -> Value -> [Instruction] +usedBy (UseSummary m) v = fromMaybe [] $ HM.lookup v m diff --git a/src/LLVM/Analysis/Util/Names.hs b/src/LLVM/Analysis/Util/Names.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/Util/Names.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TypeOperators #-} +-- | Utilities to parse the type names used by LLVM. Names are parsed +-- into the representation used by the Itanium ABI package. This +-- representation can deal with namespace qualified names and supports +-- conversion between Strings and Names. +module LLVM.Analysis.Util.Names ( + parseTypeName, + unparseTypeName, + parseFunctionName, + unparseFunctionName + ) where + +import Prelude hiding ( (.) ) +import Control.Category ( (.) ) +import Text.Boomerang +import Text.Boomerang.String + +import ABI.Itanium as ABI +import LLVM.Analysis as LLVM + +parseFunctionName :: Function -> Either String Name +parseFunctionName f = + case demangleName fname of + Left e -> Left e + Right (ABI.Function sname _) -> Right sname + Right (ABI.OverrideThunk _ (ABI.Function sname _)) -> Right sname + Right n -> Left ("Unexpected name: " ++ show n) + where + fname = identifierAsString (functionName f) + +unparseFunctionName :: Name -> Maybe String +unparseFunctionName = unparseTypeName + +parseTypeName :: String -> Either String Name +parseTypeName s = + case parseString name s of + Right n -> Right n + Left e -> Left (show e) + +unparseTypeName :: Name -> Maybe String +unparseTypeName = unparseString name + +name :: PrinterParser StringError String a (Name :- a) +name = ABI.rNestedName . rList qualifier . rList1 prefix . unqName <> + ABI.rUnscopedName . unscopedName + + +unscopedName :: PrinterParser StringError String a (UName :- a) +unscopedName = ABI.rUName . unqName + +unqName :: PrinterParser StringError String a (UnqualifiedName :- a) +unqName = ABI.rSourceName . rList1 (satisfy (/= ':')) + +-- Just a hack since we know we won't have qualifiers. It is fine if +-- it always fails because the empty list is allowed +qualifier :: PrinterParser StringError String a (CVQualifier :- a) +qualifier = ABI.rConst . lit "@@INVALID@@" + +prefix :: PrinterParser StringError String a (Prefix :- a) +prefix = ABI.rUnqualifiedPrefix . unqName . lit "::" diff --git a/src/LLVM/Analysis/Util/Testing.hs b/src/LLVM/Analysis/Util/Testing.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis/Util/Testing.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} +-- | Various functions to help test this library and analyses based on +-- it. +-- +-- The idea behind the test framework is that each 'TestDescriptor' +-- describes inputs for a test suite and automatically converts the inputs +-- to a summary value, which it compares against an expected value. It +-- reports how many such tests pass/fail. +-- +-- More concretely, each test suite specifies: +-- +-- * The test input files (via a shell glob) +-- +-- * A function to conver a test input file name to a filename +-- containing the expected outut. +-- +-- * A summary function to reduce a Module to a summary value +-- +-- * A comparison function (usually an assertion from HUnit) +-- +-- With these components, the framework reads each input file and +-- converts it to bitcode. It uses the summary function to reduce the +-- Module to a summary value and reads the expected output (using the +-- 'read' function). These two types (the summary and expected +-- output) must be identical. The comparison function is then +-- applied. If it throws an exception, the test is considered to have +-- failed. +-- +-- NOTE 1: The result type of the summary function MUST be an instance +-- of 'Read' AND the same as the type found in the expected results +-- file. +-- +-- NOTE 2: The test inputs can be C, C++, bitcode, or LLVM assembly +-- files. +module LLVM.Analysis.Util.Testing ( + -- * Types + TestDescriptor(..), + BuildException(..), + -- * Actions + testAgainstExpected, + -- * Helpers + buildModule, + readInputAndExpected + ) where + +import Control.Exception as E +import Control.Monad ( when ) +import Data.Typeable ( Typeable ) +import System.Directory ( findExecutable ) +import System.Environment ( getEnv ) +import System.Exit ( ExitCode(ExitSuccess) ) +import System.FilePath +import System.FilePath.Glob +import System.IO.Error +import System.IO.Temp +import System.Process as P + +import Test.Framework ( defaultMain, Test ) +import Test.Framework.Providers.HUnit + +import LLVM.Analysis + +data BuildException = ClangFailed FilePath ExitCode + | NoBuildMethodForInput FilePath + | OptFailed FilePath ExitCode + | NoOptBinaryFound + deriving (Typeable, Show) + +instance Exception BuildException + +-- | A description of a set of tests. +data TestDescriptor = + forall a. (Read a) => TestDescriptor { + testPattern :: String, -- ^ A shell glob pattern (relative to the project root) that collects all test inputs + testExpectedMapping :: FilePath -> FilePath, -- ^ A function to apply to an input file name to find the file containing its expected results + testResultBuilder :: Module -> a, -- ^ A function to turn a Module into a summary value of any type + testResultComparator :: String -> a -> a -> IO () -- ^ A function to compare two summary values (throws on failure) + } + +-- | An intermediate helper to turn input files into modules and +-- return the expected output. +readInputAndExpected :: (Read a) + => [String] -- ^ Arguments for opt + -> (FilePath -> IO Module) -- ^ A function to turn a bitcode file bytestring into a Module + -> (FilePath -> FilePath) -- ^ The function to map an input file name to the expected output file + -> FilePath -- ^ The input file + -> IO (FilePath, Module, a) +readInputAndExpected optOpts parseFile expectedFunc inputFile = do + let exFile = expectedFunc inputFile + exContent <- readFile exFile + -- use seq here to force the full evaluation of the read file. + let expected = length exContent `seq` read exContent + m <- buildModule [] optOpts parseFile inputFile + return (inputFile, m, expected) + +-- | This is the main test suite entry point. It takes a bitcode +-- parser and a list of test suites. +-- +-- The bitcode parser is taken as an input so that this library does +-- not have a direct dependency on any FFI code. +testAgainstExpected :: [String] -- ^ Options for opt + -> (FilePath -> IO Module) -- ^ A function to turn a bitcode file bytestring into a Module + -> [TestDescriptor] -- ^ The list of test suites to run + -> IO () +testAgainstExpected optOpts parseFile testDescriptors = do + caseSets <- mapM mkDescriptorSet testDescriptors + defaultMain $ concat caseSets + where + mkDescriptorSet :: TestDescriptor -> IO [Test] + mkDescriptorSet TestDescriptor { testPattern = pat + , testExpectedMapping = mapping + , testResultBuilder = br + , testResultComparator = cmp + } = do + + -- Glob up all of the files in the test directory with the target extension + testInputFiles <- namesMatching pat + -- Read in the expected results and corresponding modules + inputsAndExpecteds <- mapM (readInputAndExpected optOpts parseFile mapping) testInputFiles + -- Build actual test cases by applying the result builder + mapM (mkTest br cmp) inputsAndExpecteds + + mkTest br cmp (file, m, expected) = do + let actual = br m + return $ testCase file $ cmp file expected actual + +-- | Optimize the bitcode in the given bytestring using opt with the +-- provided options +optify :: [String] -> FilePath -> FilePath -> IO () +optify args inp optFile = do + opt <- findOpt + let cmd = P.proc opt ("-o" : optFile : inp : args) + (_, _, _, p) <- createProcess cmd + rc <- waitForProcess p + when (rc /= ExitSuccess) $ E.throwIO $ OptFailed inp rc + +-- | Given an input file, bitcode parsing function, and options to +-- pass to opt, return a Module. The input file can be C, C++, or +-- LLVM bitcode. +-- +-- Note that this function returns an Either value to report some +-- kinds of errors. It can also raise IOErrors. +buildModule :: [String] -- ^ Front-end options (passed to clang) for the module. + -> [String] -- ^ Optimization options (passed to opt) for the module. opt is not run if the list is empty + -> (FilePath -> IO Module) -- ^ A function to turn a bitcode file into a Module + -> FilePath -- ^ The input file (either bitcode or C/C++) + -> IO Module +buildModule clangOpts optOpts parseFile inputFilePath = do + clang <- catchIOError (getEnv "LLVM_CLANG") (const (return "clang")) + clangxx <- catchIOError (getEnv "LLVM_CLANGXX") (const (return "clang++")) + case takeExtension inputFilePath of + ".ll" -> simpleBuilder inputFilePath + ".bc" -> simpleBuilder inputFilePath + ".c" -> clangBuilder inputFilePath clang + ".C" -> clangBuilder inputFilePath clangxx + ".cxx" -> clangBuilder inputFilePath clangxx + ".cpp" -> clangBuilder inputFilePath clangxx + _ -> E.throwIO $ NoBuildMethodForInput inputFilePath + where + simpleBuilder inp + | null optOpts = parseFile inp + | otherwise = + withSystemTempFile ("opt_" ++ takeFileName inp) $ \optFname _ -> do + optify optOpts inp optFname + parseFile optFname + + clangBuilder inp driver = + withSystemTempFile ("base_" ++ takeFileName inp) $ \baseFname _ -> do + let cOpts = clangOpts ++ ["-emit-llvm", "-o" , baseFname, "-c", inp] + (_, _, _, p) <- createProcess $ proc driver cOpts + rc <- waitForProcess p + when (rc /= ExitSuccess) $ E.throwIO $ ClangFailed inputFilePath rc + case null optOpts of + True -> parseFile baseFname + False -> + withSystemTempFile ("opt_" ++ takeFileName inp) $ \optFname _ -> do + optify optOpts baseFname optFname + parseFile optFname + +-- | Find a suitable @opt@ binary in the user's PATH +-- +-- First consult the LLVM_OPT environment variable. If that is not +-- set, try a few common opt aliases. +findOpt :: IO FilePath +findOpt = do + let fbin = findBin [ "opt", "opt-3.3", "opt-3.2", "opt-3.1", "opt-3.0" ] + catchIOError (getEnv "LLVM_OPT") (const fbin) + where + findBin [] = E.throwIO NoOptBinaryFound + findBin (bin:bins) = do + b <- findExecutable bin + case b of + Just e -> return e + Nothing -> findBin bins + +{-# ANN module "HLint: ignore Use if" #-} diff --git a/tests/AccessPathTests.hs b/tests/AccessPathTests.hs new file mode 100644 --- /dev/null +++ b/tests/AccessPathTests.hs @@ -0,0 +1,54 @@ +module Main ( main ) where + +import Data.List ( find ) +import Data.Map ( Map ) +import qualified Data.Map as M +import System.Environment ( getArgs, withArgs ) +import System.FilePath ( (<.>) ) +import Test.HUnit ( assertEqual ) + +import LLVM.Analysis +import LLVM.Analysis.AccessPath +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +main :: IO () +main = do + args <- getArgs + let pattern = case args of + [] -> "tests/accesspath/*.c" + [infile] -> infile + _ -> error "Only one argument allowed" + testDescriptors = [ TestDescriptor { testPattern = pattern + , testExpectedMapping = (<.> "expected") + , testResultBuilder = extractFirstPath + , testResultComparator = assertEqual + } + ] + withArgs [] $ testAgainstExpected opts parser testDescriptors + where + opts = [ "-mem2reg", "-basicaa", "-gvn" ] + parser = parseLLVMFile defaultParserOptions + +type Summary = (String, [AccessType]) + +-- Feed the first store instruction in each function to accessPath and +-- map each function to its path. +extractFirstPath :: Module -> Map String Summary +extractFirstPath m = M.fromList $ map extractFirstFuncPath funcs + where + funcs = moduleDefinedFunctions m + +extractFirstFuncPath :: Function -> (String, Summary) +extractFirstFuncPath f = (show (functionName f), summ) + where + allInsts = concatMap basicBlockInstructions (functionBody f) + Just firstStore = find isStore allInsts + Just p = accessPath firstStore + p' = abstractAccessPath p + summ = (show (abstractAccessPathBaseType p'), + abstractAccessPathComponents p') + +isStore :: Instruction -> Bool +isStore StoreInst {} = True +isStore _ = False diff --git a/tests/AndersenTest.hs b/tests/AndersenTest.hs new file mode 100644 --- /dev/null +++ b/tests/AndersenTest.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +module Main ( main ) where + +import Data.Map ( Map ) +import Data.Set ( Set ) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Monoid +import System.Environment ( getArgs, withArgs ) +import System.FilePath +import Test.HUnit ( assertEqual ) + +import LLVM.Analysis +-- import LLVM.Analysis.PointsTo.AllocatorProfile +import LLVM.Analysis.PointsTo.Andersen +import LLVM.Analysis.PointsTo +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +#if defined(DEBUGGRAPH) +import Data.GraphViz +import System.IO.Unsafe ( unsafePerformIO ) + +viewConstraintGraph :: a -> Andersen -> a +viewConstraintGraph v a = unsafePerformIO $ do + let dg = andersenConstraintGraph a + runGraphvizCanvas' dg Gtk + return v +#else +viewConstraintGraph :: a -> Andersen -> a +viewConstraintGraph = const +#endif + +extractSummary :: Module -> Map String (Set String) +extractSummary m = + foldr addInfo mempty ptrs `viewConstraintGraph` pta + where + pta = runPointsToAnalysis m + ptrs = map toValue (globalPointerVariables m) ++ formals -- ++ map Value (functionPointerParameters m) + formals = concatMap (map toValue . functionParameters) (moduleDefinedFunctions m) + addInfo v r = + let vals = pointsTo pta v + name = maybe "???" show (valueName v) + in case null vals of + True -> r + False -> + let targets = map (maybe "??" show . valueName) vals -- `debug` show vals + in M.insert name (S.fromList targets) r + +isPointerType t = case t of + TypePointer _ _ -> True + _ -> False + +isPointer :: (IsValue a) => a -> Bool +isPointer = isPointerType . valueType + +globalPointerVariables :: Module -> [GlobalVariable] +globalPointerVariables m = filter isPointer (moduleGlobalVariables m) + +functionPointerParameters :: Module -> [Argument] +functionPointerParameters m = concatMap pointerParams (moduleDefinedFunctions m) + where + pointerParams = filter isPointer . functionParameters + +main :: IO () +main = do + args <- getArgs + let pattern = case args of + [] -> "tests/points-to-inputs/*/*.c" + [infile] -> infile + _ -> error "Only one argument allowed" + testDescriptors = [ TestDescriptor { testPattern = pattern + , testExpectedMapping = expectedMapper + , testResultBuilder = extractSummary + , testResultComparator = assertEqual + } + ] + withArgs [] $ testAgainstExpected opts parser testDescriptors + where + -- These optimizations aren't really necessary (the algorithm + -- works fine with unoptimized bitcode), but comparing the results + -- visually is much easier with the optimized version. + opts = [ "-mem2reg", "-basicaa", "-gvn" ] + parser = parseLLVMFile defaultParserOptions + expectedMapper = (<.> "expected-andersen") diff --git a/tests/BlockReturnTests.hs b/tests/BlockReturnTests.hs new file mode 100644 --- /dev/null +++ b/tests/BlockReturnTests.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ViewPatterns #-} +module Main ( main ) where + +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Monoid +import System.Environment ( getArgs, withArgs ) +import System.FilePath +import Test.HUnit ( assertEqual ) + +import LLVM.Analysis +import LLVM.Analysis.BlockReturnValue +import LLVM.Analysis.Dominance +import LLVM.Analysis.CFG +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +main :: IO () +main = do + args <- getArgs + let pattern = case args of + [] -> "tests/block-return/*.c" + [infile] -> infile + _ -> error "Only one argument allowed" + testDescriptors = [ TestDescriptor { testPattern = pattern + , testExpectedMapping = (<.> "expected") + , testResultBuilder = blockRetMap + , testResultComparator = assertEqual + } + ] + withArgs [] $ testAgainstExpected opts parser testDescriptors + where + opts = [ "-mem2reg", "-basicaa", "-gvn" ] + parser = parseLLVMFile defaultParserOptions + +data Bundle = Bundle Function PostdominatorTree CFG + +instance HasFunction Bundle where + getFunction (Bundle f _ _) = f + +instance HasPostdomTree Bundle where + getPostdomTree (Bundle _ pdt _) = pdt + +instance HasCFG Bundle where + getCFG (Bundle _ _ cfg) = cfg + +-- Take the first function in the module and summarize it (map of +-- block names to return values that are constant ints) +blockRetMap :: Module -> Map String Int +blockRetMap m = foldr (recordConstIntReturn brs) mempty blocks + where + f1 : _ = moduleDefinedFunctions m + blocks = functionBody f1 + brs = labelBlockReturns bdl + cfg = controlFlowGraph f1 + pdt = postdominatorTree cfg + bdl = Bundle f1 pdt cfg + + +recordConstIntReturn :: BlockReturns -> BasicBlock -> Map String Int -> Map String Int +recordConstIntReturn brs bb m = + case blockReturn brs bb of + Just (valueContent' -> ConstantC ConstantInt { constantIntValue = iv }) -> + M.insert (show (basicBlockName bb)) (fromIntegral iv) m + _ -> m diff --git a/tests/CallGraphTest.hs b/tests/CallGraphTest.hs new file mode 100644 --- /dev/null +++ b/tests/CallGraphTest.hs @@ -0,0 +1,50 @@ +module Main ( main ) where + +import Data.Set ( Set ) +import qualified Data.Set as S +import System.FilePath +import Test.HUnit ( assertEqual ) + +import LLVM.Analysis +import LLVM.Analysis.CallGraph +import LLVM.Analysis.PointsTo.TrivialFunction +import LLVM.Analysis.CallGraphSCCTraversal +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +main :: IO () +main = testAgainstExpected ["-mem2reg", "-basicaa"] bcParser testDescriptors + where + bcParser = parseLLVMFile defaultParserOptions + +testDescriptors :: [TestDescriptor] +testDescriptors = [ TestDescriptor { testPattern = cgPattern + , testExpectedMapping = expectedMapper + , testResultBuilder = extractTraversalOrder + , testResultComparator = assertEqual + } + ] + +cgPattern :: String +cgPattern = "tests/callgraph/order/*.c" + +expectedMapper :: FilePath -> FilePath +expectedMapper = (<.> "expected") + +extractTraversalOrder :: Module -> [Set String] +extractTraversalOrder m = + case res == pres of + True -> res + False -> error "Mismatch between serial and parallel result" + where + Just mainFunc = findMain m + pta = runPointsToAnalysis m + cg = callGraph m pta [mainFunc] + + res = callGraphSCCTraversal cg buildSummary [] + pres = parallelCallGraphSCCTraversal cg buildSummary [] + +buildSummary :: [Function] -> [Set String] -> [Set String] +buildSummary scc summ = S.fromList fnames : summ + where + fnames = map (identifierAsString . functionName) scc diff --git a/tests/ClassHierarchyTests.hs b/tests/ClassHierarchyTests.hs new file mode 100644 --- /dev/null +++ b/tests/ClassHierarchyTests.hs @@ -0,0 +1,110 @@ +module Main ( main ) where + +import Data.Generics.Uniplate.Data +import Data.List ( find ) +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Maybe ( mapMaybe ) +import Data.Set ( Set ) +import qualified Data.Set as S +import System.Environment ( getArgs, withArgs ) +import System.FilePath ( (<.>) ) +import Test.HUnit ( assertEqual ) + +import qualified ABI.Itanium as ABI + +import LLVM.Analysis +import LLVM.Analysis.ClassHierarchy +import LLVM.Analysis.Util.Names +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +main :: IO () +main = do + args <- getArgs + let pattern1 = case args of + [] -> "tests/class-hierarchy/*.cpp" + [infile] -> infile + _ -> error "Only one argument allowed" + pattern2 = case args of + [] -> "tests/virtual-dispatch/*.cpp" + [infile] -> infile + _ -> error "Only one argument allowed" + testDescriptors = [ TestDescriptor { testPattern = pattern1 + , testExpectedMapping = (<.> "expected") + , testResultBuilder = analyzeHierarchy + , testResultComparator = assertEqual + } + , TestDescriptor { testPattern = pattern2 + , testExpectedMapping = (<.> "expected") + , testResultBuilder = findCallees + , testResultComparator = assertEqual + } + ] + withArgs [] $ testAgainstExpected opts parser testDescriptors + where + opts = [ "-mem2reg", "-basicaa", "-gvn" ] + parser = parseLLVMFile defaultParserOptions + +analyzeHierarchy :: Module -> Map String (Set String) +analyzeHierarchy = classHierarchyToTestFormat . runCHA + +findCallees :: Module -> Map String (Set String) +findCallees m = M.fromList $ mapMaybe (firstCalleeTargets cha) funcs + where + cha = runCHA m + funcs = moduleDefinedFunctions m + +functionToDemangledName :: Function -> String +functionToDemangledName f = + case parseFunctionName f of + Left e -> error e + Right sname -> + case unparseFunctionName sname of + Nothing -> error ("Unable to unparse function name: " ++ show sname) + Just n -> n + +firstCalleeTargets :: CHA -> Function -> Maybe (String, Set String) +firstCalleeTargets cha f = do + case isConstructor f || isVirtualThunk f of + True -> Nothing + False -> do + firstCall <- find isCallInst insts + callees <- resolveVirtualCallee cha firstCall + return (fname, S.fromList (map functionToDemangledName callees)) + where + insts = functionInstructions f + fname = functionToDemangledName f + +isVirtualThunk :: Function -> Bool +isVirtualThunk f = + case dname of + Left _ -> False + Right sname -> + case sname of + ABI.OverrideThunk _ _ -> True + ABI.OverrideThunkCovariant _ _ _ -> True + _ -> False + where + n = identifierAsString (functionName f) + dname = ABI.demangleName n + +isConstructor :: Function -> Bool +isConstructor f = + case dname of + Left _ -> False + Right structuredName -> + case universeBi structuredName of + [ABI.C2] -> True + [ABI.C1] -> True + [ABI.C3] -> True + _ -> False + where + n = identifierAsString (functionName f) + dname = ABI.demangleName n + +isCallInst :: Instruction -> Bool +isCallInst i = + case i of + CallInst {} -> True + _ -> False diff --git a/tests/ReturnTests.hs b/tests/ReturnTests.hs new file mode 100644 --- /dev/null +++ b/tests/ReturnTests.hs @@ -0,0 +1,61 @@ +module Main ( main ) where + +import Data.Functor.Identity +import Data.Foldable ( toList ) +import Data.HashSet ( HashSet ) +import Data.Monoid +import Data.Set ( Set ) +import qualified Data.Set as S +import System.FilePath ( (<.>) ) +import System.Environment ( getArgs, withArgs ) +import Test.HUnit ( assertEqual ) + +import LLVM.Analysis +import LLVM.Analysis.CFG +import LLVM.Analysis.CallGraph +import LLVM.Analysis.CallGraphSCCTraversal +import LLVM.Analysis.PointsTo.TrivialFunction +import LLVM.Analysis.NoReturn +import LLVM.Analysis.Util.Testing +import LLVM.Parse + +main :: IO () +main = do + args <- getArgs + let pattern = case args of + [] -> "tests/noreturn/*.c" + [infile] -> infile + let testDescriptors = [ TestDescriptor { testPattern = pattern + , testExpectedMapping = (<.> "expected") + , testResultBuilder = analyzeReturns + , testResultComparator = assertEqual + } + ] + + withArgs [] $ testAgainstExpected opts parser testDescriptors + where + opts = ["-mem2reg", "-basicaa", "-gvn"] + parser = parseLLVMFile defaultParserOptions + +exitTest :: (Monad m) => ExternalFunction -> m Bool +exitTest ef = return $ "@exit" == efname + where + efname = show (externalFunctionName ef) + +nameToString :: Function -> String +nameToString = show . functionName + +runNoReturnAnalysis :: CallGraph -> (ExternalFunction -> Identity Bool) -> [Function] +runNoReturnAnalysis cg extSummary = + let analysis :: [CFG] -> HashSet Function -> HashSet Function + analysis = callGraphAnalysisM runIdentity (noReturnAnalysis extSummary) + res = callGraphSCCTraversal cg analysis mempty + in toList res + + +analyzeReturns :: Module -> Set String +analyzeReturns m = S.fromList $ map nameToString nrs + where + nrs = runNoReturnAnalysis cg exitTest -- runIdentity (noReturnAnalysis cg exitTest) + pta = runPointsToAnalysis m + cg = callGraph m pta []