packages feed

llvm-analysis (empty) → 0.3.0

raw patch · 32 files changed

+5153/−0 lines, 32 filesdep +GenericPrettydep +HUnitdep +arraysetup-changed

Dependencies added: GenericPretty, HUnit, array, base, boomerang, bytestring, containers, deepseq, directory, failure, fgl, filemanip, filepath, graphviz, hashable, hoopl, ifscs, itanium-abi, lens, llvm-analysis, llvm-base-types, llvm-data-interop, monad-par, process, temporary, test-framework, test-framework-hunit, text, transformers, uniplate, unordered-containers, vector

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ llvm-analysis.cabal view
@@ -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
+ src/LLVM/Analysis.hs view
@@ -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.
+ src/LLVM/Analysis/AccessPath.hs view
@@ -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" #-}
+ src/LLVM/Analysis/BlockReturnValue.hs view
@@ -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"
+ src/LLVM/Analysis/CDG.hs view
@@ -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, ())
+ src/LLVM/Analysis/CFG.hs view
@@ -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
+ src/LLVM/Analysis/CFG/Internal.hs view
@@ -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.++-}
+ src/LLVM/Analysis/CallGraph.hs view
@@ -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
+ src/LLVM/Analysis/CallGraph/Internal.hs view
@@ -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
+ src/LLVM/Analysis/CallGraphSCCTraversal.hs view
@@ -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
+ src/LLVM/Analysis/ClassHierarchy.hs view
@@ -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" #-}
+ src/LLVM/Analysis/Dataflow.hs view
@@ -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
+ src/LLVM/Analysis/Dominance.hs view
@@ -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" #-}
+ src/LLVM/Analysis/NoReturn.hs view
@@ -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" #-}
+ src/LLVM/Analysis/NullPointers.hs view
@@ -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).++-}
+ src/LLVM/Analysis/PointsTo.hs view
@@ -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+      _ -> []
+ src/LLVM/Analysis/PointsTo/AllocatorProfile.hs view
@@ -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
+ src/LLVM/Analysis/PointsTo/Andersen.hs view
@@ -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]+-}
+ src/LLVM/Analysis/PointsTo/TrivialFunction.hs view
@@ -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)
+ src/LLVM/Analysis/ScalarEffects.hs view
@@ -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" #-}
+ src/LLVM/Analysis/UsesOf.hs view
@@ -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
+ src/LLVM/Analysis/Util/Names.hs view
@@ -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 "::"
+ src/LLVM/Analysis/Util/Testing.hs view
@@ -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" #-}
+ tests/AccessPathTests.hs view
@@ -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
+ tests/AndersenTest.hs view
@@ -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")
+ tests/BlockReturnTests.hs view
@@ -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
+ tests/CallGraphTest.hs view
@@ -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
+ tests/ClassHierarchyTests.hs view
@@ -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
+ tests/ReturnTests.hs view
@@ -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 []