-----------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.LLVM.Translation.BlockInfo
-- Description      : Pre-translation analysis results
-- Copyright        : (c) Galois, Inc 2018-2021
-- License          : BSD3
-- Maintainer       : Rob Dockins <rdockins@galois.com>
-- Stability        : provisional
-----------------------------------------------------------------------
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE ImplicitParams        #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Lang.Crucible.LLVM.Translation.BlockInfo
  ( LLVMBlockInfoMap
  , LLVMBlockInfo(..)
  , buildBlockInfoMap
  , useTypedVal
  ) where

import Data.Foldable (toList)
import Data.List (foldl')
import Data.Maybe
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

import qualified Text.LLVM.AST as L

import           Lang.Crucible.CFG.Generator
import           Lang.Crucible.Panic ( panic )

type LLVMBlockInfoMap s = Map L.BlockLabel (LLVMBlockInfo s)

-- | Information about an LLVM basic block computed before we begin the
--   translation proper.
data LLVMBlockInfo s
  = LLVMBlockInfo
    {
      -- | The crucible block label corresponding to this LLVM block
      forall s. LLVMBlockInfo s -> Label s
block_label :: Label s

      -- | The computed \"use\" set for this block.  This is the set
      -- of identifiers that must be assigned prior to jumping to this
      -- block. They are either used directly in this block or used
      -- by a successor of this block.
      --
      -- Note! \"metadata\" nodes do not contribute to the use set.
      -- This is because LLVM itself relaxes the usual use/def rules
      -- for metadata to prevent debugging information from inhibiting
      -- optimizations.  CF https://bugs.llvm.org/show_bug.cgi?id=51155
      --
      -- Note! values referenced in phi nodes are also not included in
      -- this set, they are instead handled when examining the
      -- terminal statements of predecessor blocks.
    , forall s. LLVMBlockInfo s -> Set Ident
block_use_set :: !(Set L.Ident)

      -- | The predecessor blocks to this block (i.e., all those blocks
      -- that can jump to this one).
    , forall s. LLVMBlockInfo s -> Set BlockLabel
block_pred_set :: !(Set L.BlockLabel)

      -- | The successor blocks to this block (i.e., all those blocks
      -- that this block can jump to).
    , forall s. LLVMBlockInfo s -> Set BlockLabel
block_succ_set :: !(Set L.BlockLabel)

      -- | The statements defining this block
    , forall s. LLVMBlockInfo s -> [Stmt]
block_body :: ![L.Stmt]

      -- | Map from labels to assignments that must be made before
      -- jumping.  If this is the block info for label l',
      -- and the map has [(i1,v1),(i2,v2)] in the phi_map for block l,
      -- then basic block l is required to assign i1 = v1 and i2 = v2
      -- before jumping to block l'.
    , forall s.
LLVMBlockInfo s -> Map BlockLabel (Seq (Ident, Type, Value))
block_phi_map :: !(Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value)))
    }

-- | Construct the block info map for the given function definition.  This collects
--   information about phi-nodes, assigns crucible labels to each basic block, and
--   computes use sets for each block.
buildBlockInfoMap :: Monad m => L.Define -> Generator l s st ret m (LLVMBlockInfoMap s)
buildBlockInfoMap :: forall (m :: Type -> Type) l s (st :: Type -> Type)
       (ret :: CrucibleType).
Monad m =>
Define -> Generator l s st ret m (LLVMBlockInfoMap s)
buildBlockInfoMap Define
d =
  do LLVMBlockInfoMap s
bim0 <- [(BlockLabel, LLVMBlockInfo s)] -> LLVMBlockInfoMap s
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BlockLabel, LLVMBlockInfo s)] -> LLVMBlockInfoMap s)
-> Generator l s st ret m [(BlockLabel, LLVMBlockInfo s)]
-> Generator l s st ret m (LLVMBlockInfoMap s)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BasicBlock
 -> Generator l s st ret m (BlockLabel, LLVMBlockInfo s))
-> [BasicBlock]
-> Generator l s st ret m [(BlockLabel, LLVMBlockInfo s)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM BasicBlock -> Generator l s st ret m (BlockLabel, LLVMBlockInfo s)
forall (m :: Type -> Type) l s (st :: Type -> Type)
       (ret :: CrucibleType).
Monad m =>
BasicBlock -> Generator l s st ret m (BlockLabel, LLVMBlockInfo s)
buildBlockInfo ([BasicBlock]
 -> Generator l s st ret m [(BlockLabel, LLVMBlockInfo s)])
-> [BasicBlock]
-> Generator l s st ret m [(BlockLabel, LLVMBlockInfo s)]
forall a b. (a -> b) -> a -> b
$ Define -> [BasicBlock]
L.defBody Define
d)
     let bim1 :: LLVMBlockInfoMap s
bim1 = LLVMBlockInfoMap s -> LLVMBlockInfoMap s
forall s. LLVMBlockInfoMap s -> LLVMBlockInfoMap s
updatePredSets LLVMBlockInfoMap s
bim0
     LLVMBlockInfoMap s -> Generator l s st ret m (LLVMBlockInfoMap s)
forall a. a -> Generator l s st ret m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LLVMBlockInfoMap s -> LLVMBlockInfoMap s
forall s. LLVMBlockInfoMap s -> LLVMBlockInfoMap s
computeUseSets LLVMBlockInfoMap s
bim1)

-- | Build the initial pass of block information. This does not yet compute predecessor
--   sets or use sets.
buildBlockInfo :: Monad m => L.BasicBlock -> Generator l s st ret m (L.BlockLabel, LLVMBlockInfo s)
buildBlockInfo :: forall (m :: Type -> Type) l s (st :: Type -> Type)
       (ret :: CrucibleType).
Monad m =>
BasicBlock -> Generator l s st ret m (BlockLabel, LLVMBlockInfo s)
buildBlockInfo BasicBlock
bb = do
  let phi_map :: Map BlockLabel (Seq (Ident, Type, Value))
phi_map = [Stmt] -> Map BlockLabel (Seq (Ident, Type, Value))
buildPhiMap (BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
L.bbStmts BasicBlock
bb)
  let succ_set :: Set BlockLabel
succ_set = [Stmt] -> Set BlockLabel
buildSuccSet (BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
L.bbStmts BasicBlock
bb)
  let blk_lbl :: BlockLabel
blk_lbl = case BasicBlock -> Maybe BlockLabel
forall lab. BasicBlock' lab -> Maybe lab
L.bbLabel BasicBlock
bb of
                  Just BlockLabel
l -> BlockLabel
l
                  Maybe BlockLabel
Nothing -> String -> [String] -> BlockLabel
forall a. HasCallStack => String -> [String] -> a
panic String
"crucible-llvm:Translation.buildBlockInfo"
                             [ String
"unable to obtain label from BasicBlock" ]
  Label s
lab <- Generator l s st ret m (Label s)
forall (m :: Type -> Type) ext s (t :: Type -> Type)
       (ret :: CrucibleType).
Monad m =>
Generator ext s t ret m (Label s)
newLabel
  (BlockLabel, LLVMBlockInfo s)
-> Generator l s st ret m (BlockLabel, LLVMBlockInfo s)
forall a. a -> Generator l s st ret m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BlockLabel
blk_lbl, LLVMBlockInfo{ block_phi_map :: Map BlockLabel (Seq (Ident, Type, Value))
block_phi_map = Map BlockLabel (Seq (Ident, Type, Value))
phi_map
                                , block_use_set :: Set Ident
block_use_set = Set Ident
forall a. Monoid a => a
mempty
                                , block_pred_set :: Set BlockLabel
block_pred_set = Set BlockLabel
forall a. Monoid a => a
mempty
                                , block_succ_set :: Set BlockLabel
block_succ_set = Set BlockLabel
succ_set
                                , block_body :: [Stmt]
block_body = BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
L.bbStmts BasicBlock
bb
                                , block_label :: Label s
block_label = Label s
lab
                                })

-- | Given the statements in a basic block, find all the successor blocks,
-- i.e. the blocks this one may jump to.
buildSuccSet :: [L.Stmt] -> Set L.BlockLabel
buildSuccSet :: [Stmt] -> Set BlockLabel
buildSuccSet [] = Set BlockLabel
forall a. Monoid a => a
mempty
buildSuccSet (Stmt
s:[Stmt]
ss) =
  case Stmt -> Instr' BlockLabel
forall lab. Stmt' lab -> Instr' lab
L.stmtInstr Stmt
s of
    L.Ret{} -> Set BlockLabel
forall a. Monoid a => a
mempty
    Instr' BlockLabel
L.RetVoid -> Set BlockLabel
forall a. Monoid a => a
mempty
    Instr' BlockLabel
L.Unreachable -> Set BlockLabel
forall a. Monoid a => a
mempty
    L.Jump BlockLabel
l -> BlockLabel -> Set BlockLabel
forall a. a -> Set a
Set.singleton BlockLabel
l
    L.Br Typed Value
_ BlockLabel
l1 BlockLabel
l2 -> [BlockLabel] -> Set BlockLabel
forall a. Ord a => [a] -> Set a
Set.fromList [BlockLabel
l1,BlockLabel
l2]
    L.CallBr Type
_ Value
_ [Typed Value]
_ BlockLabel
norm [BlockLabel]
other -> [BlockLabel] -> Set BlockLabel
forall a. Ord a => [a] -> Set a
Set.fromList (BlockLabel
normBlockLabel -> [BlockLabel] -> [BlockLabel]
forall a. a -> [a] -> [a]
:[BlockLabel]
other)
    L.Invoke Type
_ Value
_ [Typed Value]
_ BlockLabel
l1 BlockLabel
l2 -> [BlockLabel] -> Set BlockLabel
forall a. Ord a => [a] -> Set a
Set.fromList [BlockLabel
l1,BlockLabel
l2]
    L.IndirectBr Typed Value
_ [BlockLabel]
ls -> [BlockLabel] -> Set BlockLabel
forall a. Ord a => [a] -> Set a
Set.fromList [BlockLabel]
ls
    L.Switch Typed Value
_ BlockLabel
ldef [(Integer, BlockLabel)]
ls -> [BlockLabel] -> Set BlockLabel
forall a. Ord a => [a] -> Set a
Set.fromList (BlockLabel
ldefBlockLabel -> [BlockLabel] -> [BlockLabel]
forall a. a -> [a] -> [a]
:((Integer, BlockLabel) -> BlockLabel)
-> [(Integer, BlockLabel)] -> [BlockLabel]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, BlockLabel) -> BlockLabel
forall a b. (a, b) -> b
snd [(Integer, BlockLabel)]
ls)
    Instr' BlockLabel
_ -> [Stmt] -> Set BlockLabel
buildSuccSet [Stmt]
ss


-- | Compute predecessor sets from the successor sets already computed in @buildBlockInfo@
updatePredSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s
updatePredSets :: forall s. LLVMBlockInfoMap s -> LLVMBlockInfoMap s
updatePredSets LLVMBlockInfoMap s
bim0 = (LLVMBlockInfoMap s
 -> (BlockLabel, BlockLabel) -> LLVMBlockInfoMap s)
-> LLVMBlockInfoMap s
-> [(BlockLabel, BlockLabel)]
-> LLVMBlockInfoMap s
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LLVMBlockInfoMap s
-> (BlockLabel, BlockLabel) -> LLVMBlockInfoMap s
forall {k} {s}.
Ord k =>
Map k (LLVMBlockInfo s)
-> (k, BlockLabel) -> Map k (LLVMBlockInfo s)
upd LLVMBlockInfoMap s
bim0 [(BlockLabel, BlockLabel)]
predEdges
  where
   upd :: Map k (LLVMBlockInfo s)
-> (k, BlockLabel) -> Map k (LLVMBlockInfo s)
upd Map k (LLVMBlockInfo s)
bim (k
to,BlockLabel
from) = (LLVMBlockInfo s -> LLVMBlockInfo s)
-> k -> Map k (LLVMBlockInfo s) -> Map k (LLVMBlockInfo s)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\LLVMBlockInfo s
bi -> LLVMBlockInfo s
bi{ block_pred_set = Set.insert from (block_pred_set bi) }) k
to Map k (LLVMBlockInfo s)
bim

   predEdges :: [(BlockLabel, BlockLabel)]
predEdges =
     [ (BlockLabel
to,BlockLabel
from) | (BlockLabel
from, LLVMBlockInfo s
bi) <- LLVMBlockInfoMap s -> [(BlockLabel, LLVMBlockInfo s)]
forall k a. Map k a -> [(k, a)]
Map.assocs LLVMBlockInfoMap s
bim0
                 , BlockLabel
to <- Set BlockLabel -> [BlockLabel]
forall a. Set a -> [a]
Set.elems (LLVMBlockInfo s -> Set BlockLabel
forall s. LLVMBlockInfo s -> Set BlockLabel
block_succ_set LLVMBlockInfo s
bi)
     ]

-- | Compute use sets for each basic block. These sets list all the
-- virtual registers that must be assigned before jumping to a
-- block.
--
-- This is essentially a backward fixpoint computation based on the
-- identifiers used in the block statements.  We iterate the use/def
-- transfer function until no more changes are made.  Because it is a
-- backward analysis, we (heuristically) examine the blocks in
-- descending order, and re-add blocks to the workset based on
-- predecessor maps.
--
-- This fixpoint computation terminates for the usual reasons: the transfer
-- function is monotonic (use sets only increase) and has no infinite
-- chains (in the worst case, all the finitely-many identifiers in the
-- function end up in every use set).
computeUseSets :: LLVMBlockInfoMap s -> LLVMBlockInfoMap s
computeUseSets :: forall s. LLVMBlockInfoMap s -> LLVMBlockInfoMap s
computeUseSets LLVMBlockInfoMap s
bim0 = LLVMBlockInfoMap s -> Set BlockLabel -> LLVMBlockInfoMap s
forall {s}.
Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop LLVMBlockInfoMap s
bim0 (LLVMBlockInfoMap s -> Set BlockLabel
forall k a. Map k a -> Set k
Map.keysSet LLVMBlockInfoMap s
bim0) -- start with all blocks in the workset
  where
  loop :: Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop Map BlockLabel (LLVMBlockInfo s)
bim Set BlockLabel
ws =
    -- choose the largest remaining block label in the workset
    case Set BlockLabel -> Maybe (BlockLabel, Set BlockLabel)
forall a. Set a -> Maybe (a, Set a)
Set.maxView Set BlockLabel
ws of
      -- if the workset is empty, we are done
      Maybe (BlockLabel, Set BlockLabel)
Nothing -> Map BlockLabel (LLVMBlockInfo s)
bim
      Just (BlockLabel
l, Set BlockLabel
ws') ->
        -- look up the current block information relating to block l
        case BlockLabel
-> Map BlockLabel (LLVMBlockInfo s) -> Maybe (LLVMBlockInfo s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim of
          Maybe (LLVMBlockInfo s)
Nothing -> String -> [String] -> Map BlockLabel (LLVMBlockInfo s)
forall a. HasCallStack => String -> [String] -> a
panic String
"computeUseSets" [String
"Could not find label", BlockLabel -> String
forall a. Show a => a -> String
show BlockLabel
l]
          Just LLVMBlockInfo s
bi ->
            -- run the transfer function and compute an updated use set
            case BlockLabel
-> LLVMBlockInfo s
-> Map BlockLabel (LLVMBlockInfo s)
-> Maybe (LLVMBlockInfo s)
forall s.
BlockLabel
-> LLVMBlockInfo s
-> Map BlockLabel (LLVMBlockInfo s)
-> Maybe (LLVMBlockInfo s)
updateUseSet BlockLabel
l LLVMBlockInfo s
bi Map BlockLabel (LLVMBlockInfo s)
bim of
              -- if there is no update, continue down the work set
              Maybe (LLVMBlockInfo s)
Nothing -> Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop Map BlockLabel (LLVMBlockInfo s)
bim Set BlockLabel
ws'
              -- if we updated the use set, record it in the block map and
              -- add all the predecessors of this block back to the work set
              Just LLVMBlockInfo s
bi' ->
                Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop (BlockLabel
-> LLVMBlockInfo s
-> Map BlockLabel (LLVMBlockInfo s)
-> Map BlockLabel (LLVMBlockInfo s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BlockLabel
l LLVMBlockInfo s
bi' Map BlockLabel (LLVMBlockInfo s)
bim) (Set BlockLabel -> Set BlockLabel -> Set BlockLabel
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set BlockLabel
ws' (LLVMBlockInfo s -> Set BlockLabel
forall s. LLVMBlockInfo s -> Set BlockLabel
block_pred_set LLVMBlockInfo s
bi'))

-- | Run the use/def transfer function on the block body and update the block info if
-- any changes are detected
updateUseSet :: L.BlockLabel -> LLVMBlockInfo s -> Map L.BlockLabel (LLVMBlockInfo s) -> Maybe (LLVMBlockInfo s)
updateUseSet :: forall s.
BlockLabel
-> LLVMBlockInfo s
-> Map BlockLabel (LLVMBlockInfo s)
-> Maybe (LLVMBlockInfo s)
updateUseSet BlockLabel
lab LLVMBlockInfo s
bi Map BlockLabel (LLVMBlockInfo s)
bim = if Set Ident
newuse Set Ident -> Set Ident -> Bool
forall a. Eq a => a -> a -> Bool
== LLVMBlockInfo s -> Set Ident
forall s. LLVMBlockInfo s -> Set Ident
block_use_set LLVMBlockInfo s
bi then Maybe (LLVMBlockInfo s)
forall a. Maybe a
Nothing else LLVMBlockInfo s -> Maybe (LLVMBlockInfo s)
forall a. a -> Maybe a
Just LLVMBlockInfo s
bi{ block_use_set = newuse }
  where
  newuse :: Set Ident
newuse = [Stmt] -> Set Ident
loop (LLVMBlockInfo s -> [Stmt]
forall s. LLVMBlockInfo s -> [Stmt]
block_body LLVMBlockInfo s
bi)

  loop :: [Stmt] -> Set Ident
loop [] = Set Ident
forall a. Monoid a => a
mempty

  -- invoke and callbr are a special case when their return values are assigned
  -- to registers: the return values can only be used in the "normal" successor
  -- block.

  loop (L.Result Ident
nm Instr' BlockLabel
i [(String, ValMd' BlockLabel)]
_md:[Stmt]
ss) =
    case Instr' BlockLabel
i of
      L.Invoke Type
_tp Value
f [Typed Value]
args BlockLabel
l_normal BlockLabel
l_unwind ->
            -- the use sets from the function value, arguments, and unwind label
        let uss :: [Set Ident]
uss = [Value -> Set Ident
useVal Value
f, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
lab BlockLabel
l_unwind Map BlockLabel (LLVMBlockInfo s)
bim] [Set Ident] -> [Set Ident] -> [Set Ident]
forall a. [a] -> [a] -> [a]
++ (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args
            -- the use set from the normal return label, note that nm is in scope here
            u_normal :: Set Ident
u_normal = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.delete Ident
nm (BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
lab BlockLabel
l_normal Map BlockLabel (LLVMBlockInfo s)
bim)
            -- invoke is a block terminator, we can ignore the tail of the list
         in [Set Ident] -> Set Ident
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions (Set Ident
u_normal Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: [Set Ident]
uss)

      L.CallBr Type
_tp Value
f [Typed Value]
args BlockLabel
l_normal [BlockLabel]
ls ->
            -- the use sets from the function value, arguments, and non-normal
            -- labels
        let uss :: [Set Ident]
uss = Value -> Set Ident
useVal Value
fSet Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
:((BlockLabel -> Set Ident) -> [BlockLabel] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockLabel
l -> BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
lab BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim) [BlockLabel]
ls [Set Ident] -> [Set Ident] -> [Set Ident]
forall a. [a] -> [a] -> [a]
++ (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args)
            -- the use set from the normal return label, note that nm is in scope here
            u_normal :: Set Ident
u_normal = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.delete Ident
nm (BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
lab BlockLabel
l_normal Map BlockLabel (LLVMBlockInfo s)
bim)
            -- callbr is a block terminator, we can ignore the tail of the list
         in [Set Ident] -> Set Ident
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions (Set Ident
u_normal Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: [Set Ident]
uss)

      -- In other cases, combine the use set of the instruction with
      -- the use set of following instructions, after deleting the register
      -- defined here
      Instr' BlockLabel
_ -> Set Ident -> Set Ident -> Set Ident
forall a. Ord a => Set a -> Set a -> Set a
Set.union (BlockLabel
-> Instr' BlockLabel
-> Map BlockLabel (LLVMBlockInfo s)
-> Set Ident
forall s.
BlockLabel
-> Instr' BlockLabel
-> Map BlockLabel (LLVMBlockInfo s)
-> Set Ident
instrUse BlockLabel
lab Instr' BlockLabel
i Map BlockLabel (LLVMBlockInfo s)
bim) (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.delete Ident
nm ([Stmt] -> Set Ident
loop [Stmt]
ss))

  loop (L.Effect Instr' BlockLabel
i [(String, ValMd' BlockLabel)]
_md:[Stmt]
ss) = Set Ident -> Set Ident -> Set Ident
forall a. Ord a => Set a -> Set a -> Set a
Set.union (BlockLabel
-> Instr' BlockLabel
-> Map BlockLabel (LLVMBlockInfo s)
-> Set Ident
forall s.
BlockLabel
-> Instr' BlockLabel
-> Map BlockLabel (LLVMBlockInfo s)
-> Set Ident
instrUse BlockLabel
lab Instr' BlockLabel
i Map BlockLabel (LLVMBlockInfo s)
bim) ([Stmt] -> Set Ident
loop [Stmt]
ss)

instrUse :: L.BlockLabel -> L.Instr -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident
instrUse :: forall s.
BlockLabel
-> Instr' BlockLabel
-> Map BlockLabel (LLVMBlockInfo s)
-> Set Ident
instrUse BlockLabel
from Instr' BlockLabel
i Map BlockLabel (LLVMBlockInfo s)
bim = [Set Ident] -> Set Ident
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions ([Set Ident] -> Set Ident) -> [Set Ident] -> Set Ident
forall a b. (a -> b) -> a -> b
$ case Instr' BlockLabel
i of
  L.Phi{} -> [] -- NB, phi node use is handled in `useLabel`
  Instr' BlockLabel
L.RetVoid -> []
  L.Ret Typed Value
tv -> [Typed Value -> Set Ident
useTypedVal Typed Value
tv]
  L.Arith ArithOp
_op Typed Value
x Value
y -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y]
  L.Bit BitOp
_op Typed Value
x Value
y -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y ]
  L.Conv ConvOp
_op Typed Value
x Type
_tp -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.Call Bool
_tailCall Type
_tp Value
f [Typed Value]
args -> Value -> Set Ident
useVal Value
f Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args
  -- NB, this is only correct for "callbr" instructions that don't assign the return value
  L.CallBr Type
_tp Value
f [Typed Value]
args BlockLabel
norm [BlockLabel]
ls ->
    [Value -> Set Ident
useVal Value
f, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
norm Map BlockLabel (LLVMBlockInfo s)
bim] [Set Ident] -> [Set Ident] -> [Set Ident]
forall a. [a] -> [a] -> [a]
++
      (BlockLabel -> Set Ident) -> [BlockLabel] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockLabel
l -> BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim) [BlockLabel]
ls [Set Ident] -> [Set Ident] -> [Set Ident]
forall a. [a] -> [a] -> [a]
++
      (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args
  L.Alloca Type
_tp Maybe (Typed Value)
Nothing  Maybe Int
_align -> []
  L.Alloca Type
_tp (Just Typed Value
x) Maybe Int
_align -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.Load Type
_tp Typed Value
p Maybe AtomicOrdering
_ord Maybe Int
_align -> [Typed Value -> Set Ident
useTypedVal Typed Value
p]
  L.Store Typed Value
p Typed Value
v Maybe AtomicOrdering
_ord Maybe Int
_align -> [Typed Value -> Set Ident
useTypedVal Typed Value
p, Typed Value -> Set Ident
useTypedVal Typed Value
v]
  L.Fence{} -> []
  L.CmpXchg Bool
_weak Bool
_vol Typed Value
p Typed Value
v1 Typed Value
v2 Maybe String
_s AtomicOrdering
_o1 AtomicOrdering
_o2 -> (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value
p,Typed Value
v1,Typed Value
v2]
  L.AtomicRW Bool
_vol AtomicRWOp
_op Typed Value
p Typed Value
v Maybe String
_s AtomicOrdering
_o -> [Typed Value -> Set Ident
useTypedVal Typed Value
p, Typed Value -> Set Ident
useTypedVal Typed Value
v]
  L.ICmp ICmpOp
_op Typed Value
x Value
y -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y]
  L.FCmp FCmpOp
_op Typed Value
x Value
y -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y]
  L.GEP Bool
_ib Type
_tp Typed Value
base [Typed Value]
args -> Typed Value -> Set Ident
useTypedVal Typed Value
base Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args
  L.Select Typed Value
c Typed Value
x Value
y -> [ Typed Value -> Set Ident
useTypedVal Typed Value
c, Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y ]
  L.ExtractValue Typed Value
x [Int32]
_ixs -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.InsertValue Typed Value
x Typed Value
y [Int32]
_ixs -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Typed Value -> Set Ident
useTypedVal Typed Value
y]
  L.ExtractElt Typed Value
x Value
y -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y]
  L.InsertElt Typed Value
x Typed Value
y Value
z -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Typed Value -> Set Ident
useTypedVal Typed Value
y, Value -> Set Ident
useVal Value
z]
  L.ShuffleVector Typed Value
x Value
y Typed Value
z -> [Typed Value -> Set Ident
useTypedVal Typed Value
x, Value -> Set Ident
useVal Value
y, Typed Value -> Set Ident
useTypedVal Typed Value
z]
  L.Jump BlockLabel
l -> [BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim]
  L.Br Typed Value
c BlockLabel
l1 BlockLabel
l2 -> [Typed Value -> Set Ident
useTypedVal Typed Value
c, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l1 Map BlockLabel (LLVMBlockInfo s)
bim, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l2 Map BlockLabel (LLVMBlockInfo s)
bim]
  -- NB, this is only correct for "invoke" instructions that don't assign the return value
  L.Invoke Type
_tp Value
f [Typed Value]
args BlockLabel
l1 BlockLabel
l2 -> [Value -> Set Ident
useVal Value
f, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l1 Map BlockLabel (LLVMBlockInfo s)
bim, BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l2 Map BlockLabel (LLVMBlockInfo s)
bim] [Set Ident] -> [Set Ident] -> [Set Ident]
forall a. [a] -> [a] -> [a]
++ (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
args
  L.Comment{} -> []
  Instr' BlockLabel
L.Unreachable -> []
  Instr' BlockLabel
L.Unwind -> [] -- ??
  L.VaArg Typed Value
x Type
_tp -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.IndirectBr Typed Value
x [BlockLabel]
ls -> Typed Value -> Set Ident
useTypedVal Typed Value
x Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: [ BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim | BlockLabel
l <- [BlockLabel]
ls ]
  L.Switch Typed Value
c BlockLabel
def [(Integer, BlockLabel)]
bs -> Typed Value -> Set Ident
useTypedVal Typed Value
c Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
def Map BlockLabel (LLVMBlockInfo s)
bim Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: [ BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
l Map BlockLabel (LLVMBlockInfo s)
bim | (Integer
_,BlockLabel
l) <- [(Integer, BlockLabel)]
bs ]
  L.Resume Typed Value
x -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.LandingPad Type
_tp Maybe (Typed Value)
Nothing Bool
_ [Clause' BlockLabel]
cls -> (Clause' BlockLabel -> Set Ident)
-> [Clause' BlockLabel] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Clause' BlockLabel -> Set Ident
useClause [Clause' BlockLabel]
cls
  L.LandingPad Type
_tp (Just Typed Value
cleanup) Bool
_ [Clause' BlockLabel]
cls -> Typed Value -> Set Ident
useTypedVal Typed Value
cleanup Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: (Clause' BlockLabel -> Set Ident)
-> [Clause' BlockLabel] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Clause' BlockLabel -> Set Ident
useClause [Clause' BlockLabel]
cls
  L.UnaryArith UnaryArithOp
_op Typed Value
x -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]
  L.Freeze Typed Value
x -> [Typed Value -> Set Ident
useTypedVal Typed Value
x]

useClause :: L.Clause -> Set L.Ident
useClause :: Clause' BlockLabel -> Set Ident
useClause (L.Catch Typed Value
v) = Typed Value -> Set Ident
useTypedVal Typed Value
v
useClause (L.Filter Typed Value
v) = Typed Value -> Set Ident
useTypedVal Typed Value
v

useLabel :: L.BlockLabel -> L.BlockLabel -> Map L.BlockLabel (LLVMBlockInfo s) -> Set L.Ident
useLabel :: forall s.
BlockLabel
-> BlockLabel -> Map BlockLabel (LLVMBlockInfo s) -> Set Ident
useLabel BlockLabel
from BlockLabel
to Map BlockLabel (LLVMBlockInfo s)
bim =
  case BlockLabel
-> Map BlockLabel (LLVMBlockInfo s) -> Maybe (LLVMBlockInfo s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockLabel
to Map BlockLabel (LLVMBlockInfo s)
bim of
    Maybe (LLVMBlockInfo s)
Nothing -> String -> [String] -> Set Ident
forall a. HasCallStack => String -> [String] -> a
panic String
"useLabel" [String
"Could not find label", BlockLabel -> String
forall a. Show a => a -> String
show BlockLabel
to]
    Just LLVMBlockInfo s
bi ->
      let phiList :: [(Ident, Type, Value)]
phiList =
            case BlockLabel
-> Map BlockLabel (Seq (Ident, Type, Value))
-> Maybe (Seq (Ident, Type, Value))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockLabel
from (LLVMBlockInfo s -> Map BlockLabel (Seq (Ident, Type, Value))
forall s.
LLVMBlockInfo s -> Map BlockLabel (Seq (Ident, Type, Value))
block_phi_map LLVMBlockInfo s
bi) of
              Maybe (Seq (Ident, Type, Value))
Nothing -> []
              Just Seq (Ident, Type, Value)
ps -> Seq (Ident, Type, Value) -> [(Ident, Type, Value)]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq (Ident, Type, Value)
ps
      in [Set Ident] -> Set Ident
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions (LLVMBlockInfo s -> Set Ident
forall s. LLVMBlockInfo s -> Set Ident
block_use_set LLVMBlockInfo s
bi Set Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
: [ Value -> Set Ident
useVal Value
v | (Ident
_,Type
_,Value
v) <- [(Ident, Type, Value)]
phiList ])

-- | Compute the set of identifiers referenced by the given typed value
useTypedVal :: L.Typed (L.Value) -> Set L.Ident
useTypedVal :: Typed Value -> Set Ident
useTypedVal Typed Value
tv = Value -> Set Ident
useVal (Typed Value -> Value
forall a. Typed a -> a
L.typedValue Typed Value
tv)

-- | Compute the set of identifiers referenced by the given value
useVal :: L.Value -> Set L.Ident
useVal :: Value -> Set Ident
useVal Value
v = [Set Ident] -> Set Ident
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions ([Set Ident] -> Set Ident) -> [Set Ident] -> Set Ident
forall a b. (a -> b) -> a -> b
$ case Value
v of
  L.ValInteger{} ->  []
  L.ValBool{} -> []
  L.ValFloat{} -> []
  L.ValDouble{} -> []
  L.ValFP80{} -> []
  L.ValIdent Ident
i -> [Ident -> Set Ident
forall a. a -> Set a
Set.singleton Ident
i]
  L.ValSymbol Symbol
_s -> []
  Value
L.ValNull -> []
  L.ValArray Type
_tp [Value]
vs -> (Value -> Set Ident) -> [Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Set Ident
useVal [Value]
vs
  L.ValVector Type
_tp [Value]
vs -> (Value -> Set Ident) -> [Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Set Ident
useVal [Value]
vs
  L.ValStruct [Typed Value]
vs -> (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
vs
  L.ValPackedStruct [Typed Value]
vs -> (Typed Value -> Set Ident) -> [Typed Value] -> [Set Ident]
forall a b. (a -> b) -> [a] -> [b]
map Typed Value -> Set Ident
useTypedVal [Typed Value]
vs
  L.ValString [Word8]
_ -> []
  L.ValConstExpr{} -> [] -- TODO? should we look through constant exprs?
  Value
L.ValUndef -> []
  L.ValLabel BlockLabel
_ -> []
  Value
L.ValZeroInit -> []
  L.ValAsm{} -> [] -- TODO! inline asm ...
  L.ValPoison{} -> []

  -- NB! metadata values are not considered as part of our use analysis
  L.ValMd ValMd' BlockLabel
_md -> []


-- | Given the statements in a basic block, find all the phi instructions and
-- compute the list of assignments that must be made for each predecessor block.
buildPhiMap :: [L.Stmt] -> Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value))
buildPhiMap :: [Stmt] -> Map BlockLabel (Seq (Ident, Type, Value))
buildPhiMap [Stmt]
ss = [Stmt]
-> Map BlockLabel (Seq (Ident, Type, Value))
-> Map BlockLabel (Seq (Ident, Type, Value))
forall {k}.
Ord k =>
[Stmt' k]
-> Map k (Seq (Ident, Type, Value' k))
-> Map k (Seq (Ident, Type, Value' k))
go [Stmt]
ss Map BlockLabel (Seq (Ident, Type, Value))
forall k a. Map k a
Map.empty
 where go :: [Stmt' k]
-> Map k (Seq (Ident, Type, Value' k))
-> Map k (Seq (Ident, Type, Value' k))
go (L.Result Ident
ident (L.Phi Type
tp [(Value' k, k)]
xs) [(String, ValMd' k)]
_ : [Stmt' k]
stmts) Map k (Seq (Ident, Type, Value' k))
m = [Stmt' k]
-> Map k (Seq (Ident, Type, Value' k))
-> Map k (Seq (Ident, Type, Value' k))
go [Stmt' k]
stmts (Ident
-> Type
-> [(Value' k, k)]
-> Map k (Seq (Ident, Type, Value' k))
-> Map k (Seq (Ident, Type, Value' k))
forall {k} {a} {b} {c}.
Ord k =>
a
-> b -> [(c, k)] -> Map k (Seq (a, b, c)) -> Map k (Seq (a, b, c))
go' Ident
ident Type
tp [(Value' k, k)]
xs Map k (Seq (Ident, Type, Value' k))
m)
       go [Stmt' k]
_ Map k (Seq (Ident, Type, Value' k))
m = Map k (Seq (Ident, Type, Value' k))
m

       f :: a -> Maybe (Seq a) -> Maybe (Seq a)
f a
x Maybe (Seq a)
mseq = Seq a -> Maybe (Seq a)
forall a. a -> Maybe a
Just (Seq a -> Maybe (Seq a) -> Seq a
forall a. a -> Maybe a -> a
fromMaybe Seq a
forall a. Seq a
Seq.empty Maybe (Seq a)
mseq Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
x)

       go' :: a
-> b -> [(c, k)] -> Map k (Seq (a, b, c)) -> Map k (Seq (a, b, c))
go' a
ident b
tp ((c
v, k
lbl) : [(c, k)]
xs) Map k (Seq (a, b, c))
m = a
-> b -> [(c, k)] -> Map k (Seq (a, b, c)) -> Map k (Seq (a, b, c))
go' a
ident b
tp [(c, k)]
xs ((Maybe (Seq (a, b, c)) -> Maybe (Seq (a, b, c)))
-> k -> Map k (Seq (a, b, c)) -> Map k (Seq (a, b, c))
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ((a, b, c) -> Maybe (Seq (a, b, c)) -> Maybe (Seq (a, b, c))
forall {a}. a -> Maybe (Seq a) -> Maybe (Seq a)
f (a
ident,b
tp,c
v)) k
lbl Map k (Seq (a, b, c))
m)
       go' a
_ b
_ [] Map k (Seq (a, b, c))
m = Map k (Seq (a, b, c))
m