<commit_before>module Data.LLVM.CFG ( CFG
                     , EdgeCondition(..)
                     , makeCFG
                     ) where

import Data.List (foldl')
import Data.Graph.Inductive
import Data.GraphViz
import Data.Map ((!))
import qualified Data.Map as M

import Data.LLVM.Private.Printers ( )
import Data.LLVM.Private.ReferentialTypes

import Debug.Trace

debug = flip trace

type CFG = Gr Value EdgeCondition

data EdgeCondition = UnconditionalEdge
                   | DefaultEdge
                   | TrueEdge Value
                   | FalseEdge Value
                   | EqualityEdge Value Value
                   | IndirectEdge Value
                   deriving (Ord, Eq)

instance Show EdgeCondition where
  show UnconditionalEdge = ""
  show DefaultEdge = "<default>"
  show (TrueEdge v) = {- show v ++ -}" is true"
  show (FalseEdge v) = {- show v ++ -} " is false"
  show (EqualityEdge v1 v2) = "is" -- concat [ show v1, " is ", show v2 ]
  show (IndirectEdge v) = show v ++ " (indirect)"

-- | Each instruction in the function body is a node in the graph.
-- Branching instructions induce edges.  This form of the CFG is
-- fine-grained in that each instruction has its own CFG node.  This
-- is simpler to analyze, generally.
--
-- The other function, makeCompactCFG, has a basic-block-granularity
-- CFG that can be easier to visualize.
makeCFG :: Value -> CFG
makeCFG func = mkGraph (cfgNodes `debug` ("nnodes = " ++ show cfgNodes)) $ concat (cfgEdges `debug` ("nedges: " ++ show (take 5 cfgEdges)))
  where body = functionBody $ valueContent func
        (cfgNodes, cfgEdges, nodeIDs) = foldl buildGraphBlock ([], [], M.empty) (body `debug` ("Blocks: " ++ show (length body)))
        instIdent :: Value -> Int
        instIdent v = nodeIDs ! v
        jumpTargetId :: Value -> Int
        jumpTargetId Value { valueContent = BasicBlock (t:_) } = instIdent t
        jumpTargetId v = error $ "Value is not a basic block: " ++ show v
        caseEdge thisNodeId cond (val, dest) =
          (thisNodeId, jumpTargetId dest, EqualityEdge cond val)
        indirectEdge thisNodeId addr target =
          (thisNodeId, jumpTargetId target, IndirectEdge addr)
        buildGraphBlock acc Value { valueContent = BasicBlock allInsts@(_:insts) } =
          (foldl buildGraphInst acc instsAndSuccs) `debug` ("Insts and succs: " ++ show instsAndSuccs)
          where instsAndSuccs = if null insts
                                then terminator
                                else offsetPairs ++ terminator
                offsetPairs = zip allInsts $ map Just insts
                terminator = [(last allInsts, Nothing)]
        buildGraphBlock _ v = error $ "Not a BasicBlock: " ++ show v
        buildGraphInst acc (v@Value { valueContent = c }, Nothing) =
          (nodeAcc', edgeAcc', nodeMap') `debug` ("Built edges for terminator " ++ show v)
          where (nodeAcc, edgeAcc, nodeMap) = acc
                nodeAcc' = thisNode : nodeAcc
                edgeAcc' = theseEdges : edgeAcc
                nodeMap' = M.insert v thisNodeId nodeMap
                thisNodeId = M.size nodeMap
                thisNode = (thisNodeId, v)
                -- Note: branch targets are all basic blocks.  The
                -- lookup function handles grabbing the first real
                -- instruction from the basic block.
                theseEdges = case c of
                  -- Returns have no intraprocedural edges
                  RetInst _ -> []
                  -- Unwinds also have no intraprocedural edges
                  UnwindInst -> []
                  -- A single target (no label needed)
                  UnconditionalBranchInst tgt ->
                    [ (thisNodeId, jumpTargetId tgt, UnconditionalEdge) ]
                  -- Two edges (cond is true, cond is false)
                  BranchInst { branchCondition = cond
                             , branchTrueTarget = tTarget
                             , branchFalseTarget = fTarget
                             } ->
                    [ (thisNodeId, jumpTargetId tTarget, UnconditionalEdge) -- TrueEdge cond)
                    , (thisNodeId, jumpTargetId fTarget, UnconditionalEdge) -- FalseEdge cond)
                    ]
                  SwitchInst { switchValue = cond
                             , switchDefaultTarget = defTarget
                             , switchCases = cases
                             } ->
                    ( thisNodeId
                    , jumpTargetId defTarget
                    , DefaultEdge) : map (caseEdge thisNodeId cond) cases
                  IndirectBranchInst { indirectBranchAddress = addr
                                     , indirectBranchTargets = targets
                                     } ->
                    map (indirectEdge thisNodeId addr) targets
                  _ -> error ("Last instruction in a block should be a jump: " ++ show v)
        buildGraphInst acc (v@Value { valueContent = c }, Just successor) =
          (nodeAcc', edgeAcc', nodeMap') `debug` ("Built edges for " ++ show v)
          -- buildGraphInst (nodeAcc', edgeAcc', nodeMap') rest
          where (nodeAcc, edgeAcc, nodeMap) = acc
                nodeAcc' = thisNode : nodeAcc
                edgeAcc' = theseEdges : edgeAcc
                nodeMap' = M.insert v thisNodeId nodeMap
                thisNodeId = M.size nodeMap
                thisNode = (thisNodeId, v)
                theseEdges = case c of
                  Function {} -> error "Functions should not be in the CFG"
                  GlobalDeclaration {} -> error "Globals should not be in the CFG"
                  GlobalAlias {} -> error "Global aliases should not be in the CFG"
                  ExternalValue -> error "External values should not be in the CFG"
                  ExternalFunction _ -> error "External functions should not be in the CFG"
                  BasicBlock _ -> error "Basic blocks should not be in the CFG"<commit_msg>Assign integer nodeids to each instruction before building the nodes/edges<commit_after>module Data.LLVM.CFG ( CFG
                     , EdgeCondition(..)
                     , makeCFG
                     ) where

import Data.List (foldl')
import Data.Graph.Inductive
import Data.GraphViz
import Data.Map ((!))
import qualified Data.Map as M

import Data.LLVM.Private.Printers ( )
import Data.LLVM.Private.ReferentialTypes

import Debug.Trace

debug = flip trace

type CFG = Gr Value EdgeCondition

data EdgeCondition = UnconditionalEdge
                   | DefaultEdge
                   | TrueEdge Value
                   | FalseEdge Value
                   | EqualityEdge Value Value
                   | IndirectEdge Value
                   deriving (Ord, Eq)

instance Show EdgeCondition where
  show UnconditionalEdge = ""
  show DefaultEdge = "<default>"
  show (TrueEdge v) = {- show v ++ -}" is true"
  show (FalseEdge v) = {- show v ++ -} " is false"
  show (EqualityEdge v1 v2) = "is" -- concat [ show v1, " is ", show v2 ]
  show (IndirectEdge v) = show v ++ " (indirect)"

-- | Each instruction in the function body is a node in the graph.
-- Branching instructions induce edges.  This form of the CFG is
-- fine-grained in that each instruction has its own CFG node.  This
-- is simpler to analyze, generally.
--
-- The other function, makeCompactCFG, has a basic-block-granularity
-- CFG that can be easier to visualize.
makeCFG :: Value -> CFG
makeCFG func = mkGraph (cfgNodes `debug` ("nnodes = " ++ show cfgNodes)) $ concat (cfgEdges `debug` ("nedges: " ++ show (take 4 cfgEdges)))
  where body = functionBody $ valueContent func
        allInstructions = concatMap (\(Value { valueContent = BasicBlock is }) -> is) body
        (nodeCount, nodeIDs) = foldl' labelInstruction (0, M.empty) allInstructions
        labelInstruction (idx, m) val = (idx+1, M.insert val idx m)
        (cfgNodes, cfgEdges) = foldl' buildGraphBlock ([], []) (body `debug` ("Blocks: " ++ show (length body)))

        instIdent :: Value -> Int
        instIdent v = nodeIDs ! v
        jumpTargetId :: Value -> Int
        jumpTargetId Value { valueContent = BasicBlock (t:_) } = instIdent (t `debug` ("Target for jump: " ++ show (instIdent t)))
        jumpTargetId v = error $ "Value is not a basic block: " ++ show v

        caseEdge thisNodeId cond (val, dest) =
          (thisNodeId, jumpTargetId dest, EqualityEdge cond val)
        indirectEdge thisNodeId addr target =
          (thisNodeId, jumpTargetId target, IndirectEdge addr)
        buildGraphBlock acc Value { valueContent = BasicBlock allInsts@(_:insts) } =
          (foldl' buildGraphInst acc instsAndSuccs) `debug` ("Insts and succs: " ++ show instsAndSuccs)
          where instsAndSuccs = if null insts
                                then terminator
                                else offsetPairs ++ terminator
                offsetPairs = zip allInsts $ map Just insts
                terminator = [(last allInsts, Nothing)]
        buildGraphBlock _ v = error $ "Not a BasicBlock: " ++ show v
        buildGraphInst acc (v@Value { valueContent = c }, Nothing) =
          (nodeAcc', edgeAcc') `debug` ("Built edges for terminator (" ++ show theseEdges ++ ")")
          where (nodeAcc, edgeAcc) = acc
                nodeAcc' = thisNode : nodeAcc
                edgeAcc' = theseEdges : edgeAcc
                thisNodeId = instIdent v
                thisNode = (thisNodeId, v) `debug` ("Trying to build terminator inst edges: " ++ show v)
                -- Note: branch targets are all basic blocks.  The
                -- lookup function handles grabbing the first real
                -- instruction from the basic block.
                theseEdges = case c `debug` ("Switching on " ++ show v) of
                  -- Returns have no intraprocedural edges
                  RetInst _ -> []
                  -- Unwinds also have no intraprocedural edges
                  UnwindInst -> []
                  -- A single target (no label needed)
                  UnconditionalBranchInst tgt ->
                    [ (thisNodeId, jumpTargetId tgt, UnconditionalEdge) ]
                  -- Two edges (cond is true, cond is false)
                  BranchInst { branchCondition = cond
                             , branchTrueTarget = tTarget
                             , branchFalseTarget = fTarget
                             } ->
                    [ (thisNodeId, jumpTargetId tTarget `debug` ("true edge "), UnconditionalEdge) -- TrueEdge cond)
                    , (thisNodeId, jumpTargetId fTarget `debug` "false edge", UnconditionalEdge) -- FalseEdge cond)
                    ]
                  SwitchInst { switchValue = cond
                             , switchDefaultTarget = defTarget
                             , switchCases = cases
                             } ->
                    ( thisNodeId
                    , jumpTargetId defTarget
                    , DefaultEdge) : map (caseEdge thisNodeId cond) cases
                  IndirectBranchInst { indirectBranchAddress = addr
                                     , indirectBranchTargets = targets
                                     } ->
                    map (indirectEdge thisNodeId addr) targets
                  _ -> error ("Last instruction in a block should be a jump: " ++ show v)
        buildGraphInst acc (v@Value { valueContent = c }, Just successor) =
          (nodeAcc', edgeAcc') `debug` ("Built edges for " ++ show v)
          where (nodeAcc, edgeAcc) = acc
                nodeAcc' = thisNode : nodeAcc
                edgeAcc' = theseEdges : edgeAcc
                thisNodeId = instIdent v
                thisNode = (thisNodeId, v) `debug` ("A node: " ++ show v)
                theseEdges = case c of
                  Function {} -> error "Functions should not be in the CFG"
                  GlobalDeclaration {} -> error "Globals should not be in the CFG"
                  GlobalAlias {} -> error "Global aliases should not be in the CFG"
                  ExternalValue -> error "External values should not be in the CFG"
                  ExternalFunction _ -> error "External functions should not be in the CFG"
                  BasicBlock _ -> error "Basic blocks should not be in the CFG"
{'fraction_non_alphanumeric': 0.08367280430177611, 'fraction_numerical': 0.000977676389115203, 'mean_word_length': 1.7193176783340718, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 38, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6846833', 'n_tokens_mistral': 3180, 'n_tokens_neox': 3041, 'n_words': 1097}