{-# 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)
data LLVMBlockInfo s
= LLVMBlockInfo
{
forall s. LLVMBlockInfo s -> Label s
block_label :: Label s
, forall s. LLVMBlockInfo s -> Set Ident
block_use_set :: !(Set L.Ident)
, forall s. LLVMBlockInfo s -> Set BlockLabel
block_pred_set :: !(Set L.BlockLabel)
, forall s. LLVMBlockInfo s -> Set BlockLabel
block_succ_set :: !(Set L.BlockLabel)
, forall s. LLVMBlockInfo s -> [Stmt]
block_body :: ![L.Stmt]
, forall s.
LLVMBlockInfo s -> Map BlockLabel (Seq (Ident, Type, Value))
block_phi_map :: !(Map L.BlockLabel (Seq (L.Ident, L.Type, L.Value)))
}
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)
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
})
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
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)
]
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)
where
loop :: Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop Map BlockLabel (LLVMBlockInfo s)
bim Set BlockLabel
ws =
case Set BlockLabel -> Maybe (BlockLabel, Set BlockLabel)
forall a. Set a -> Maybe (a, Set a)
Set.maxView Set BlockLabel
ws of
Maybe (BlockLabel, Set BlockLabel)
Nothing -> Map BlockLabel (LLVMBlockInfo s)
bim
Just (BlockLabel
l, Set BlockLabel
ws') ->
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 ->
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
Maybe (LLVMBlockInfo s)
Nothing -> Map BlockLabel (LLVMBlockInfo s)
-> Set BlockLabel -> Map BlockLabel (LLVMBlockInfo s)
loop Map BlockLabel (LLVMBlockInfo s)
bim Set BlockLabel
ws'
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'))
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
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 ->
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
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)
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 ->
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)
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)
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)
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{} -> []
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
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]
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 ])
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)
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{} -> []
Value
L.ValUndef -> []
L.ValLabel BlockLabel
_ -> []
Value
L.ValZeroInit -> []
L.ValAsm{} -> []
L.ValPoison{} -> []
L.ValMd ValMd' BlockLabel
_md -> []
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