-----------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.LLVM.Translation.Aliases
-- Description      : Resolution of global and function aliases
-- Copyright        : (c) Galois, Inc 2018
-- License          : BSD3
-- Maintainer       : Rob Dockins <rdockins@galois.com>
-- Stability        : provisional
-----------------------------------------------------------------------
{-# 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

-- | Reverse a set of alias/aliasee relationships
--
-- Given a list of values @l : List A@ and a function @aliasOf : A -> A@,
-- compute a map @Map A (Set A)@ which records the set of things that are
-- transitive aliases of a given @a : A@.
--
-- The keys in the resulting map should be only terminals, e.g. those @a@
-- which aren't aliases of another @a'@ in @l@.
--
-- Requires that the elements of the input sequence are unique.
--
-- Outline:
-- * Initialize the empty map @M : Map A (Set A)@
-- * Initialize an auxilary map @N : Map A A@ which records the final aliasee
--   of each key (the last one in the chain of aliases).
-- * For each @a : A@ in l,
--   1. If @aliasOf a@ is in @N@ as @aliasee@,
--       a. insert @aliasee@ at key @a@ in @N@ (memoize the result)
--       b. insert @a@ into the set at key @aliasee@ in @M@ (record the result)
--       c. recurse on @s@ minus @aliasee@ and @a@.
--   2. If @aliasOf a@ is in @s@, recurse on @l ++ [a]@
--   3. Otherwise,
--       a. insert @a@ at key @a@ in @N@ (memoize the result)
--       b. return the map as-is
--
-- For the sake of practical concerns, the implementation uses \"labels\" for
-- comparison and @aliasOf@, and uses sequences rather than lists.
reverseAliases :: (Ord a, Ord l, Show a, Show l)
               => (a -> l)         -- ^ \"Label of\"
               -> (a -> Maybe l)   -- ^ \"Alias of\"
               -> 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 -- Don't overwrite it if it's already in the map
                 (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
>>                        -- 1a
                     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_)                              -- 1b
                        ((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) -- 1c
                   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)                          -- 2
                     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
>>                         -- 3a
                          Map a (Set a) -> Seq a -> State (Map l a) (Map a (Set a))
go Map a (Set a)
map_ Seq a
as                                               -- 3b
                 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

-- | This is one step closer to the application of 'reverseAliases':
-- There are two \"sorts\" of objects:
-- Objects in sort @a@ are never aliases (think global variables).
-- Objects in sort @b@ are usually aliases, to things of either sort
-- (think aliases to global variables).
reverseAliasesTwoSorted :: (Ord a, Ord b, Ord l, Show a, Show b, Show l)
                        => (a -> l)       -- ^ \"Label of\" for type @a@
                        -> (b -> l)       -- ^ \"Label of\" for type @b@
                        -> (b -> Maybe l) -- ^ \"Alias of\"
                        -> 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 -- Drop the b's which have been added as keys and
        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
        -- Call "error" if an a has been tagged as an alias
        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)
        -- TODO: Should this throw an exception?
        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

-- | What does this alias point to?
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
    -- All other things silently get dropped; it's invalid LLVM code to not have
    -- a symbol or constexpr.
    Value
_ -> Maybe Symbol
forall a. Maybe a
Nothing

-- | Get all the aliases that alias (transitively) to a certain global.
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_))

-- | Get all the aliases that alias (transitively) to a certain function.
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_))