{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TypeFamilies #-}
module Lang.Crucible.LLVM.Translation.Aliases
( globalAliases
, functionAliases
, reverseAliases
) where
import Control.Monad
import Control.Monad.Trans.State
import qualified Data.List as List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Text.LLVM.AST as L
import Lang.Crucible.Panic (panic)
import Lang.Crucible.LLVM.Types
import Lang.Crucible.LLVM.TypeContext (TypeContext)
import Lang.Crucible.LLVM.Translation.Constant
reverseAliases :: (Ord a, Ord l, Show a, Show l)
=> (a -> l)
-> (a -> Maybe l)
-> Seq a
-> Map a (Set a)
reverseAliases :: forall a l.
(Ord a, Ord l, Show a, Show l) =>
(a -> l) -> (a -> Maybe l) -> Seq a -> Map a (Set a)
reverseAliases a -> l
lab a -> Maybe l
aliasOf_ Seq a
seq_ =
State (Map l a) (Map a (Set a)) -> Map l a -> Map a (Set a)
forall s a. State s a -> s -> a
evalState (Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go Map a (Set a)
forall k a. Map k a
Map.empty Seq a
seq_) (Map l a
forall k a. Map k a
Map.empty :: Map l a)
where go :: Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go Map a (Set a)
map_ Seq a
Seq.Empty = Map a (Set a) -> State (Map l a) (Map a (Set a))
forall a. a -> StateT (Map l a) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Map a (Set a)
map_
go Map a (Set a)
map_ (a
a Seq.:<| Seq a
as) =
case a -> Maybe l
aliasOf_ a
a of
Maybe l
Nothing ->
do
(Map l a -> Map l a) -> StateT (Map l a) Identity ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify (l -> a -> Map l a -> Map l a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> l
lab a
a) a
a)
Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go ((Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\Set a
_ Set a
old -> Set a
old) a
a Set a
forall a. Set a
Set.empty Map a (Set a)
map_) Seq a
as
Just l
l ->
do Bool
-> StateT (Map l a) Identity () -> StateT (Map l a) Identity ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (a -> l
lab a
a l -> l -> Bool
forall a. Eq a => a -> a -> Bool
== l
l) (StateT (Map l a) Identity () -> StateT (Map l a) Identity ())
-> StateT (Map l a) Identity () -> StateT (Map l a) Identity ()
forall a b. (a -> b) -> a -> b
$
String -> [String] -> StateT (Map l a) Identity ()
forall a. HasCallStack => String -> [String] -> a
panic String
"reverseAliases" [ String
"Self-alias:", a -> String
forall a. Show a => a -> String
show a
a ]
Map l a
st <- StateT (Map l a) Identity (Map l a)
forall (m :: Type -> Type) s. Monad m => StateT s m s
get
case l -> Map l a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup l
l Map l a
st of
Just a
aliasee ->
(Map l a -> Map l a) -> StateT (Map l a) Identity ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify (l -> a -> Map l a -> Map l a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> l
lab a
a) a
aliasee) StateT (Map l a) Identity ()
-> State (Map l a) (Map a (Set a))
-> State (Map l a) (Map a (Set a))
forall a b.
StateT (Map l a) Identity a
-> StateT (Map l a) Identity b -> StateT (Map l a) Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>>
Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go (a -> a -> Map a (Set a) -> Map a (Set a)
forall {k} {a}.
(Ord k, Ord a) =>
k -> a -> Map k (Set a) -> Map k (Set a)
mapSetInsert a
aliasee a
a Map a (Set a)
map_)
((a -> Bool) -> Seq a -> Seq a
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (\a
b -> a -> l
lab a
b l -> l -> Bool
forall a. Eq a => a -> a -> Bool
/= a -> l
lab a
aliasee Bool -> Bool -> Bool
&& a -> l
lab a
b l -> l -> Bool
forall a. Eq a => a -> a -> Bool
/= l
l) Seq a
as)
Maybe a
Nothing ->
if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust ((a -> Bool) -> Seq a -> Maybe a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find ((l
l l -> l -> Bool
forall a. Eq a => a -> a -> Bool
==) (l -> Bool) -> (a -> l) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> l
lab) Seq a
as)
then Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go Map a (Set a)
map_ (Seq a
as Seq a -> Seq a -> Seq a
forall a. Semigroup a => a -> a -> a
<> a -> Seq a
forall a. a -> Seq a
Seq.singleton a
a)
else (Map l a -> Map l a) -> StateT (Map l a) Identity ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify (l -> a -> Map l a -> Map l a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> l
lab a
a) a
a) StateT (Map l a) Identity ()
-> State (Map l a) (Map a (Set a))
-> State (Map l a) (Map a (Set a))
forall a b.
StateT (Map l a) Identity a
-> StateT (Map l a) Identity b -> StateT (Map l a) Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>>
Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go Map a (Set a)
map_ Seq a
as
where mapSetInsert :: k -> a -> Map k (Set a) -> Map k (Set a)
mapSetInsert k
k a
v Map k (Set a)
m = (Set a -> Maybe (Set a)) -> k -> Map k (Set a) -> Map k (Set a)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Set a -> Maybe (Set a)
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Set a -> Maybe (Set a))
-> (Set a -> Set a) -> Set a -> Maybe (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v) k
k Map k (Set a)
m
reverseAliasesTwoSorted :: (Ord a, Ord b, Ord l, Show a, Show b, Show l)
=> (a -> l)
-> (b -> l)
-> (b -> Maybe l)
-> Seq a
-> Seq b
-> Map a (Set b)
reverseAliasesTwoSorted :: forall a b l.
(Ord a, Ord b, Ord l, Show a, Show b, Show l) =>
(a -> l)
-> (b -> l) -> (b -> Maybe l) -> Seq a -> Seq b -> Map a (Set b)
reverseAliasesTwoSorted a -> l
laba b -> l
labb b -> Maybe l
aliasOf_ Seq a
seqa Seq b
seqb =
[(a, Set b)] -> Map a (Set b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, Set b)] -> Map a (Set b))
-> (Map (Either a b) (Set (Either a b)) -> [(a, Set b)])
-> Map (Either a b) (Set (Either a b))
-> Map a (Set b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either a b, Set (Either a b)) -> Maybe (a, Set b))
-> [(Either a b, Set (Either a b))] -> [(a, Set b)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Either a b, Set (Either a b)) -> Maybe (a, Set b)
forall {b} {a} {b} {a}.
Ord b =>
(Either a b, Set (Either a b)) -> Maybe (a, Set b)
go ([(Either a b, Set (Either a b))] -> [(a, Set b)])
-> (Map (Either a b) (Set (Either a b))
-> [(Either a b, Set (Either a b))])
-> Map (Either a b) (Set (Either a b))
-> [(a, Set b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Either a b) (Set (Either a b))
-> [(Either a b, Set (Either a b))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Either a b) (Set (Either a b)) -> Map a (Set b))
-> Map (Either a b) (Set (Either a b)) -> Map a (Set b)
forall a b. (a -> b) -> a -> b
$
(Either a b -> l)
-> (Either a b -> Maybe l)
-> Seq (Either a b)
-> Map (Either a b) (Set (Either a b))
forall a l.
(Ord a, Ord l, Show a, Show l) =>
(a -> l) -> (a -> Maybe l) -> Seq a -> Map a (Set a)
reverseAliases ((a -> l) -> (b -> l) -> Either a b -> l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> l
laba b -> l
labb)
((a -> Maybe l) -> (b -> Maybe l) -> Either a b -> Maybe l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe l -> a -> Maybe l
forall a b. a -> b -> a
const Maybe l
forall a. Maybe a
Nothing) b -> Maybe l
aliasOf_)
((a -> Either a b) -> Seq a -> Seq (Either a b)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left Seq a
seqa Seq (Either a b) -> Seq (Either a b) -> Seq (Either a b)
forall a. Semigroup a => a -> a -> a
<> (b -> Either a b) -> Seq b -> Seq (Either a b)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right Seq b
seqb)
where
go :: (Either a b, Set (Either a b)) -> Maybe (a, Set b)
go (Right b
_, Set (Either a b)
_) = Maybe (a, Set b)
forall a. Maybe a
Nothing
go (Left a
k, Set (Either a b)
s) = (a, Set b) -> Maybe (a, Set b)
forall a. a -> Maybe a
Just (a
k, (Either a b -> b) -> Set (Either a b) -> Set b
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Either a b -> b
forall {a} {a}. Either a a -> a
errLeft Set (Either a b)
s)
errLeft :: Either a a -> a
errLeft (Left a
_) = String -> a
forall a. HasCallStack => String -> a
error String
"Internal error: unexpected Left value"
errLeft (Right a
v) = a
v
aliasOf :: (?lc :: TypeContext, HasPtrWidth wptr)
=> L.GlobalAlias
-> Maybe L.Symbol
aliasOf :: forall (wptr :: Natural).
(?lc::TypeContext, HasPtrWidth wptr) =>
GlobalAlias -> Maybe Symbol
aliasOf GlobalAlias
alias =
case GlobalAlias -> Value
L.aliasTarget GlobalAlias
alias of
L.ValSymbol Symbol
symb -> Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just Symbol
symb
L.ValConstExpr ConstExpr' BlockLabel
constExpr ->
case ConstExpr' BlockLabel -> Either String LLVMConst
forall (m :: Type -> Type) (wptr :: Natural).
(?lc::TypeContext, MonadError String m, HasPtrWidth wptr) =>
ConstExpr' BlockLabel -> m LLVMConst
transConstantExpr ConstExpr' BlockLabel
constExpr of
Right (SymbolConst Symbol
symb Integer
0) -> Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just Symbol
symb
Either String LLVMConst
_ -> Maybe Symbol
forall a. Maybe a
Nothing
Value
_ -> Maybe Symbol
forall a. Maybe a
Nothing
globalAliases :: (?lc :: TypeContext, HasPtrWidth wptr)
=> L.Module
-> Map L.Symbol (Set L.GlobalAlias)
globalAliases :: forall (wptr :: Natural).
(?lc::TypeContext, HasPtrWidth wptr) =>
Module -> Map Symbol (Set GlobalAlias)
globalAliases Module
mod_ = (Global -> Symbol)
-> Map Global (Set GlobalAlias) -> Map Symbol (Set GlobalAlias)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Global -> Symbol
L.globalSym (Map Global (Set GlobalAlias) -> Map Symbol (Set GlobalAlias))
-> Map Global (Set GlobalAlias) -> Map Symbol (Set GlobalAlias)
forall a b. (a -> b) -> a -> b
$
(Global -> Symbol)
-> (GlobalAlias -> Symbol)
-> (GlobalAlias -> Maybe Symbol)
-> Seq Global
-> Seq GlobalAlias
-> Map Global (Set GlobalAlias)
forall a b l.
(Ord a, Ord b, Ord l, Show a, Show b, Show l) =>
(a -> l)
-> (b -> l) -> (b -> Maybe l) -> Seq a -> Seq b -> Map a (Set b)
reverseAliasesTwoSorted Global -> Symbol
L.globalSym GlobalAlias -> Symbol
L.aliasName GlobalAlias -> Maybe Symbol
forall (wptr :: Natural).
(?lc::TypeContext, HasPtrWidth wptr) =>
GlobalAlias -> Maybe Symbol
aliasOf
([Global] -> Seq Global
forall a. [a] -> Seq a
Seq.fromList (Module -> [Global]
L.modGlobals Module
mod_)) ([GlobalAlias] -> Seq GlobalAlias
forall a. [a] -> Seq a
Seq.fromList (Module -> [GlobalAlias]
L.modAliases Module
mod_))
functionAliases :: (?lc :: TypeContext, HasPtrWidth wptr)
=> L.Module
-> Map L.Symbol (Set L.GlobalAlias)
functionAliases :: forall (wptr :: Natural).
(?lc::TypeContext, HasPtrWidth wptr) =>
Module -> Map Symbol (Set GlobalAlias)
functionAliases Module
mod_ = (Define -> Symbol)
-> Map Define (Set GlobalAlias) -> Map Symbol (Set GlobalAlias)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Define -> Symbol
L.defName (Map Define (Set GlobalAlias) -> Map Symbol (Set GlobalAlias))
-> Map Define (Set GlobalAlias) -> Map Symbol (Set GlobalAlias)
forall a b. (a -> b) -> a -> b
$
(Define -> Symbol)
-> (GlobalAlias -> Symbol)
-> (GlobalAlias -> Maybe Symbol)
-> Seq Define
-> Seq GlobalAlias
-> Map Define (Set GlobalAlias)
forall a b l.
(Ord a, Ord b, Ord l, Show a, Show b, Show l) =>
(a -> l)
-> (b -> l) -> (b -> Maybe l) -> Seq a -> Seq b -> Map a (Set b)
reverseAliasesTwoSorted Define -> Symbol
L.defName GlobalAlias -> Symbol
L.aliasName GlobalAlias -> Maybe Symbol
forall (wptr :: Natural).
(?lc::TypeContext, HasPtrWidth wptr) =>
GlobalAlias -> Maybe Symbol
aliasOf
([Define] -> Seq Define
forall a. [a] -> Seq a
Seq.fromList (Module -> [Define]
L.modDefines Module
mod_)) ([GlobalAlias] -> Seq GlobalAlias
forall a. [a] -> Seq a
Seq.fromList (Module -> [GlobalAlias]
L.modAliases Module
mod_))