{-# LANGUAGE LambdaCase #-}

{- |
Module      : Text.LLVM.Combine
Description : Combine LLVM Modules
License     : BSD3
Maintainer  : Kevin Quick <kquick@galois.com>
Stability   : provisional

This module provides the ability to smash together LLVM 'Module' specifications
to provide the ability to load separate LLVM 'Module's (e.g. bitcode files) and
analyze them as if they had been linked together as a single program.

-}

module Text.LLVM.Combine
  (
    llvmModuleCombine
  )
where

import Data.Bool ( bool )
import Data.Generics.Schemes ( everywhere )
import Data.Generics.Aliases ( mkT )
import Lens.Micro
import Lens.Micro.Extras
import Data.Function ( on )
import Data.List ( find )
import Data.Maybe ( fromMaybe )
import Data.String ( fromString )
import Text.LLVM.AST
import Text.LLVM.Lens


-- | Combines LLVM 'Module's into a single, composite 'Module'.  This is akin to
-- linking, but just from the perspective of what is needed for program analysis.
--
-- This differs from `llvm-link` in the following known ways:
--
-- 1. The `llvm-link` tool uses structural typing resolution: if two modules
--    each have a type with the same structure, the resulting module will only
--    have one type; the name from one of the modules is chosen and all
--    references to the typename in the other module will be rewritten to the
--    first module.
--
--    The `llvmModuleCombine` function takes a slightly different approach: types
--    are not structurally coalesced, but this means that type names are
--    deconflicted by adding a numbered suffix.  This still requires modifying
--    the type name throughout that module, but (a) there are probably fewer type
--    name conflicts than structural equivalences, and (b) the original name is
--    still part of the new name which maintains origin information.
--
-- 2. The `llvm-link` tool will occasionally rewrite calls to llvm intrinsics to
--    explicitly add the default personality specification.  For example,
--    `llvm.stacksave` may be rewritten to `llvm.stacksave.p0`.  Because these
--    are intrinsics, this should not have any significant impact on the result,
--    but `llvmModuleCombine` does not perform this naming update.
--
-- 3. External declaration resolution is type independent and only name
--    sensitive.  If 'Module' A has an external declaration `declare @f(i32 x)`
--    and 'Module' B has a definition `define @f(float x)`, then this
--    `llvmModuleCombine` operation will use the latter to satisfy the former (by
--    removing the former) even though the types do not match.
--
llvmModuleCombine :: Module -> Module -> Module
llvmModuleCombine :: Module -> Module -> Module
llvmModuleCombine Module
a Module
addModule =
  let defs :: [Define]
defs = Module
a Module -> Getting [Define] Module [Define] -> [Define]
forall s a. s -> Getting a s a -> a
^. Getting [Define] Module [Define]
Lens' Module [Define]
modDefinesLens
      decls :: [Declare]
decls = Module
a Module -> Getting [Declare] Module [Declare] -> [Declare]
forall s a. s -> Getting a s a -> a
^. Getting [Declare] Module [Declare]
Lens' Module [Declare]
modDeclaresLens
      newDefs :: [Define]
newDefs = Module
b Module -> Getting [Define] Module [Define] -> [Define]
forall s a. s -> Getting a s a -> a
^. Getting [Define] Module [Define]
Lens' Module [Define]
modDefinesLens
      newDecls :: [Declare]
newDecls = Module
b Module -> Getting [Declare] Module [Declare] -> [Declare]
forall s a. s -> Getting a s a -> a
^. Getting [Declare] Module [Declare]
Lens' Module [Declare]
modDeclaresLens
      rmvDefined :: [Define] -> [Declare] -> [Declare]
rmvDefined = ([Declare] -> [Define] -> [Declare])
-> [Define] -> [Declare] -> [Declare]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Define -> [Declare] -> [Declare])
-> [Declare] -> [Define] -> [Declare]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Define -> [Declare] -> [Declare]
removeDefined)
      newDeclsLessOldDefs :: [Declare]
newDeclsLessOldDefs = [Define] -> [Declare] -> [Declare]
rmvDefined [Define]
defs [Declare]
newDecls
      oldDeclsLessNewDefs :: [Declare]
oldDeclsLessNewDefs = [Define] -> [Declare] -> [Declare]
rmvDefined [Define]
newDefs [Declare]
decls
      joinedName :: Maybe String -> Maybe String
joinedName Maybe String
n = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"..." Maybe String
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"+" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"..." (Module -> Maybe String
modSourceName Module
b)
      newUmdBase :: UnnamedMdIdx
newUmdBase = let umIdxs :: [UnnamedMdIdx]
umIdxs = UnnamedMd -> UnnamedMdIdx
umIndex (UnnamedMd -> UnnamedMdIdx) -> [UnnamedMd] -> [UnnamedMdIdx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> [UnnamedMd]
modUnnamedMd Module
a
                   in UnnamedMdIdx -> UnnamedMdIdx -> Bool -> UnnamedMdIdx
forall a. a -> a -> Bool -> a
bool (UnnamedMdIdx -> UnnamedMdIdx
forall a. Enum a => a -> a
succ (UnnamedMdIdx -> UnnamedMdIdx) -> UnnamedMdIdx -> UnnamedMdIdx
forall a b. (a -> b) -> a -> b
$ [UnnamedMdIdx] -> UnnamedMdIdx
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [UnnamedMdIdx]
umIdxs) (Int -> UnnamedMdIdx
UnnamedMdIdx Int
0) (Bool -> UnnamedMdIdx) -> Bool -> UnnamedMdIdx
forall a b. (a -> b) -> a -> b
$ [UnnamedMdIdx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnnamedMdIdx]
umIdxs
      -- unnamed metadata is referenced almost everywhere, so update that globally
      -- first:
      b :: Module
b = UnnamedMdIdx -> Module -> Module
updateUmd UnnamedMdIdx
newUmdBase (Module -> [TypeDecl] -> Module
deConflictTypes Module
addModule (Module
a Module -> Getting [TypeDecl] Module [TypeDecl] -> [TypeDecl]
forall s a. s -> Getting a s a -> a
^. Getting [TypeDecl] Module [TypeDecl]
Lens' Module [TypeDecl]
modTypesLens))
  in Module
a
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& (Maybe String -> Identity (Maybe String))
-> Module -> Identity Module
Lens' Module (Maybe String)
modSourceNameLens ((Maybe String -> Identity (Maybe String))
 -> Module -> Identity Module)
-> (Maybe String -> Maybe String) -> Module -> Module
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe String -> Maybe String
joinedName
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([Declare] -> Identity [Declare]) -> Module -> Identity Module
Lens' Module [Declare]
modDeclaresLens (([Declare] -> Identity [Declare]) -> Module -> Identity Module)
-> [Declare] -> Module -> Module
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ([Declare]
oldDeclsLessNewDefs [Declare] -> [Declare] -> [Declare]
forall a. Semigroup a => a -> a -> a
<> [Declare]
newDeclsLessOldDefs)
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([Define] -> Identity [Define]) -> Module -> Identity Module
Lens' Module [Define]
modDefinesLens (([Define] -> Identity [Define]) -> Module -> Identity Module)
-> ([Define] -> [Define]) -> Module -> Module
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [Define] -> [Define] -> [Define]
deConflict (Module
b Module -> Getting [Define] Module [Define] -> [Define]
forall s a. s -> Getting a s a -> a
^. Getting [Define] Module [Define]
Lens' Module [Define]
modDefinesLens)
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([TypeDecl] -> Identity [TypeDecl]) -> Module -> Identity Module
Lens' Module [TypeDecl]
modTypesLens (([TypeDecl] -> Identity [TypeDecl]) -> Module -> Identity Module)
-> [TypeDecl] -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module -> Getting [TypeDecl] Module [TypeDecl] -> [TypeDecl]
forall s a. s -> Getting a s a -> a
^. Getting [TypeDecl] Module [TypeDecl]
Lens' Module [TypeDecl]
modTypesLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([UnnamedMd] -> Identity [UnnamedMd]) -> Module -> Identity Module
Lens' Module [UnnamedMd]
modUnnamedMdLens (([UnnamedMd] -> Identity [UnnamedMd])
 -> Module -> Identity Module)
-> [UnnamedMd] -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module -> Getting [UnnamedMd] Module [UnnamedMd] -> [UnnamedMd]
forall s a. s -> Getting a s a -> a
^. Getting [UnnamedMd] Module [UnnamedMd]
Lens' Module [UnnamedMd]
modUnnamedMdLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([NamedMd] -> Identity [NamedMd]) -> Module -> Identity Module
Lens' Module [NamedMd]
modNamedMdLens (([NamedMd] -> Identity [NamedMd]) -> Module -> Identity Module)
-> [NamedMd] -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module -> Getting [NamedMd] Module [NamedMd] -> [NamedMd]
forall s a. s -> Getting a s a -> a
^. Getting [NamedMd] Module [NamedMd]
Lens' Module [NamedMd]
modNamedMdLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& (Map String SelectionKind -> Identity (Map String SelectionKind))
-> Module -> Identity Module
Lens' Module (Map String SelectionKind)
modComdatLens ((Map String SelectionKind -> Identity (Map String SelectionKind))
 -> Module -> Identity Module)
-> Map String SelectionKind -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module
-> Getting
     (Map String SelectionKind) Module (Map String SelectionKind)
-> Map String SelectionKind
forall s a. s -> Getting a s a -> a
^. Getting
  (Map String SelectionKind) Module (Map String SelectionKind)
Lens' Module (Map String SelectionKind)
modComdatLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([Global] -> Identity [Global]) -> Module -> Identity Module
Lens' Module [Global]
modGlobalsLens (([Global] -> Identity [Global]) -> Module -> Identity Module)
-> [Global] -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module -> Getting [Global] Module [Global] -> [Global]
forall s a. s -> Getting a s a -> a
^. Getting [Global] Module [Global]
Lens' Module [Global]
modGlobalsLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& (InlineAsm -> Identity InlineAsm) -> Module -> Identity Module
Lens' Module InlineAsm
modInlineAsmLens ((InlineAsm -> Identity InlineAsm) -> Module -> Identity Module)
-> InlineAsm -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module -> Getting InlineAsm Module InlineAsm -> InlineAsm
forall s a. s -> Getting a s a -> a
^. Getting InlineAsm Module InlineAsm
Lens' Module InlineAsm
modInlineAsmLens
     Module -> (Module -> Module) -> Module
forall a b. a -> (a -> b) -> b
& ([GlobalAlias] -> Identity [GlobalAlias])
-> Module -> Identity Module
Lens' Module [GlobalAlias]
modAliasesLens (([GlobalAlias] -> Identity [GlobalAlias])
 -> Module -> Identity Module)
-> [GlobalAlias] -> Module -> Module
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Module
b Module
-> Getting [GlobalAlias] Module [GlobalAlias] -> [GlobalAlias]
forall s a. s -> Getting a s a -> a
^. Getting [GlobalAlias] Module [GlobalAlias]
Lens' Module [GlobalAlias]
modAliasesLens
  -- TODO Globals any should override Linkage external for the same name
  -- TODO verify modTriple and modDataLayout are the same?


-- | Rewrites type references in the input module to ensure uniqueness against
-- all types mentioned in the second module.
deConflictTypes :: Module -> [TypeDecl] -> Module
deConflictTypes :: Module -> [TypeDecl] -> Module
deConflictTypes Module
inpMod [TypeDecl]
existingTypes =
  let resolveTypeConflict :: a -> TypeDecl -> a
resolveTypeConflict a
m TypeDecl
t =
        if (TypeDecl -> Bool) -> [TypeDecl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Ident -> Ident -> Bool)
-> (TypeDecl -> Ident) -> TypeDecl -> TypeDecl -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TypeDecl -> Ident
typeName) TypeDecl
t) [TypeDecl]
existingTypes
        then a -> TypeDecl -> String -> Int -> a
forall {a} {a}.
(Ord a, Num a, Enum a, Data a, Show a) =>
a -> TypeDecl -> String -> a -> a
renameType a
m TypeDecl
t (let Ident String
n = TypeDecl -> Ident
typeName TypeDecl
t in String
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"___") (Int
0 :: Int)
        else a
m
      renameType :: a -> TypeDecl -> String -> a -> a
renameType a
m TypeDecl
t String
b a
n =
        let newName :: Ident
newName = String -> Ident
Ident (String
b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n)
        in if (TypeDecl -> Bool) -> [TypeDecl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Ident
newName Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
==) (Ident -> Bool) -> (TypeDecl -> Ident) -> TypeDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDecl -> Ident
typeName) [TypeDecl]
existingTypes
           then if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
100000
                then String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Unable to generate unique type name for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
b
                else a -> TypeDecl -> String -> a -> a
renameType a
m TypeDecl
t String
b (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
succ a
n
           else (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Ident -> Ident) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Ident -> Ident -> Ident -> Ident
forall {a}. Eq a => a -> a -> a -> a
chngType (TypeDecl -> Ident
typeName TypeDecl
t) Ident
newName)) a
m
      chngType :: a -> a -> a -> a
chngType a
oldName a
newName a
n = a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool a
n a
newName (Bool -> a) -> Bool -> a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
oldName
  in (Module -> TypeDecl -> Module) -> Module -> [TypeDecl] -> Module
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Module -> TypeDecl -> Module
forall {a}. Data a => a -> TypeDecl -> a
resolveTypeConflict Module
inpMod (Module
inpMod Module -> Getting [TypeDecl] Module [TypeDecl] -> [TypeDecl]
forall s a. s -> Getting a s a -> a
^. Getting [TypeDecl] Module [TypeDecl]
Lens' Module [TypeDecl]
modTypesLens)


-- | A 'Define' takes precedence over a 'Declare'.  When combining modules,
-- module A may 'Declare' a function that is handled by a 'Define' in module B,
-- so get rid of the 'Declare' when putting A and B together.

removeDefined :: Define -> [Declare] -> [Declare]
removeDefined :: Define -> [Declare] -> [Declare]
removeDefined Define
def = (Declare -> Bool) -> [Declare] -> [Declare]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Define
def Define -> Getting Symbol Define Symbol -> Symbol
forall s a. s -> Getting a s a -> a
^. Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Symbol -> Bool) -> (Declare -> Symbol) -> Declare -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Symbol Declare Symbol -> Declare -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Declare Symbol
Lens' Declare Symbol
decNameLens)


-- | 'Module' A and 'Module' B may have a Define with the same name ('Symbol').
-- This is normal when linking multiple modules together, and is resolved by
-- linkers as guided by the 'Linkage' information for the two 'Definition's,
-- usually by either renaming or merging.

deConflict :: [Define] -> [Define] -> [Define]
deConflict :: [Define] -> [Define] -> [Define]
deConflict [Define]
new [Define]
curr = ([Define] -> [Define] -> [Define])
-> ([Define], [Define]) -> [Define]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Define] -> [Define] -> [Define]
forall a. Semigroup a => a -> a -> a
(<>) (([Define], [Define]) -> [Define])
-> ([Define], [Define]) -> [Define]
forall a b. (a -> b) -> a -> b
$ (([Define], [Define]) -> Define -> ([Define], [Define]))
-> ([Define], [Define]) -> [Define] -> ([Define], [Define])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([Define], [Define]) -> Define -> ([Define], [Define])
deConflictDef ([Define]
curr, [Define]
new) [Define]
new
  where
    deConflictDef :: ([Define], [Define]) -> Define -> ([Define], [Define])
deConflictDef ([Define]
ads, [Define]
bds) Define
bd =
      case (Define -> Bool) -> [Define] -> Maybe Define
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Symbol -> Symbol -> Bool)
-> (Define -> Symbol) -> Define -> Define -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Define -> Symbol
defName) Define
bd) [Define]
ads of
        Maybe Define
Nothing -> ([Define]
ads, [Define]
bds)
        Just Define
ad -> [Define] -> [Define] -> Define -> Define -> ([Define], [Define])
handle [Define]
ads [Define]
bds Define
ad Define
bd
    handle :: [Define] -> [Define] -> Define -> Define -> ([Define], [Define])
handle [Define]
ads [Define]
bds Define
ad Define
bd =
      case Define
bd Define
-> Getting (Maybe Linkage) Define (Maybe Linkage) -> Maybe Linkage
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Linkage) Define (Maybe Linkage)
Lens' Define (Maybe Linkage)
defLinkageLens of
        Just Linkage
Private -> ([Define]
ads, Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
bd (Getting Symbol Define Symbol -> Define -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens (Define -> Symbol) -> [Define] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Define]
ads) [Define]
bds)
        Just Linkage
LinkerPrivate -> ([Define]
ads, Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
bd (Getting Symbol Define Symbol -> Define -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens (Define -> Symbol) -> [Define] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Define]
ads) [Define]
bds)
        Just Linkage
LinkerPrivateWeak ->
          ([Define]
ads, Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
bd (Getting Symbol Define Symbol -> Define -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens (Define -> Symbol) -> [Define] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Define]
ads) [Define]
bds) -- ??
        Just Linkage
LinkerPrivateWeakDefAuto ->
          ([Define]
ads, Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
bd (Getting Symbol Define Symbol -> Define -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens (Define -> Symbol) -> [Define] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Define]
ads) [Define]
bds) -- ??
        Just Linkage
Internal -> ([Define]
ads, Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
bd (Getting Symbol Define Symbol -> Define -> Symbol
forall a s. Getting a s a -> s -> a
view Getting Symbol Define Symbol
Lens' Define Symbol
defNameLens (Define -> Symbol) -> [Define] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Define]
ads) [Define]
bds)
        Just Linkage
AvailableExternally ->
          -- Never happen: not allowed on defines.  Ignore
          ([Define]
ads, [Define]
bds)
        Just Linkage
Linkonce -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
Weak -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
Common -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
ExternWeak -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
LinkonceODR -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
WeakODR -> (Define -> Define -> [Define] -> [Define]
mergeDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
Appending -> (Define -> Define -> [Define] -> [Define]
appendDef Define
ad Define
bd [Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
External ->
          -- This should never happen: it is truly a symbol conflict.  A
          -- linker would reject this, but here we will just preserve the
          -- original.
          ([Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)
        Just Linkage
DLLImport -> ([Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds) -- ??
        Just Linkage
DLLExport -> ([Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds) -- ??
        Maybe Linkage
Nothing ->
          -- No linkage specified.  The default is 'External', with associated
          -- considerations as documented for that case above.
          ([Define]
ads, Define -> [Define] -> [Define]
removeDef Define
bd [Define]
bds)

-- Note: Used for Linkonce, Weak, Common, ExternWeak, LinkonceODR, WeakODR. LLVM
-- docs say "merged", but also indicates that maybe there is a replacement
-- instead?  For now, treat "merged" as appending.
mergeDef :: Define -> Define -> [Define] -> [Define]
mergeDef :: Define -> Define -> [Define] -> [Define]
mergeDef = Define -> Define -> [Define] -> [Define]
appendDef

appendDef :: Define -> Define -> [Define] -> [Define]
appendDef :: Define -> Define -> [Define] -> [Define]
appendDef Define
d1 Define
d2 =
  let appenD :: Define
appenD = Define
d1 Define -> (Define -> Define) -> Define
forall a b. a -> (a -> b) -> b
& ([BasicBlock] -> Identity [BasicBlock])
-> Define -> Identity Define
Lens' Define [BasicBlock]
defBodyLens (([BasicBlock] -> Identity [BasicBlock])
 -> Define -> Identity Define)
-> [BasicBlock] -> Define -> Define
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Define
d2 Define -> Getting [BasicBlock] Define [BasicBlock] -> [BasicBlock]
forall s a. s -> Getting a s a -> a
^. Getting [BasicBlock] Define [BasicBlock]
Lens' Define [BasicBlock]
defBodyLens
  in (Define
appenD Define -> [Define] -> [Define]
forall a. a -> [a] -> [a]
:) ([Define] -> [Define])
-> ([Define] -> [Define]) -> [Define] -> [Define]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Define -> Bool) -> [Define] -> [Define]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Symbol -> Symbol -> Bool)
-> (Define -> Symbol) -> Define -> Define -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Define -> Symbol
defName) Define
d1)

removeDef :: Define -> [Define] -> [Define]
removeDef :: Define -> [Define] -> [Define]
removeDef Define
d = (Define -> Bool) -> [Define] -> [Define]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Symbol -> Symbol -> Bool)
-> (Define -> Symbol) -> Define -> Define -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Define -> Symbol
defName) Define
d)


-- Renames the Defined symbol to a new name using a discriminator to avoid a
-- conflict.  Only valid for renaming Private/Internal Defines such that changing
-- any reference to the original Symbol to the new Symbol in the provided set of
-- Defines is sufficient to change all references.  Note therefore this excludes:
-- renaming of global variables, changing a GlobalAlias.

renameDef :: Define -> [Symbol] -> [Define] -> [Define]
renameDef :: Define -> [Symbol] -> [Define] -> [Define]
renameDef Define
toRename [Symbol]
known [Define]
inDefs =
  -- KWQ TODO: needs to change GlobalAlias aliasName?
  --
  let getNewName :: String -> a -> String
getNewName String
nm a
n =
        -- Note: adds a "discriminator" to the name in a way that is valid for
        -- both C functions and C++ mangled names (see
        -- https://itanium-cxx-abi.github.io/cxx-abi/abi.html#mangling-scope).
        let nn :: String
nn = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10
                 then String
nm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n
                 else String
nm String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"__" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_"
        in case (Define -> Bool) -> [Define] -> Maybe Define
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> Symbol
forall a. IsString a => String -> a
fromString String
nn Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
==) (Symbol -> Bool) -> (Define -> Symbol) -> Define -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Define -> Symbol
defName) [Define]
inDefs of
             Just Define
_ -> String -> a -> String
getNewName String
nm (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
succ a
n
             Maybe Define
Nothing ->
               if String -> Symbol
forall a. IsString a => String -> a
fromString String
nn Symbol -> [Symbol] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
known
               then String -> a -> String
getNewName String
nm (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
succ a
n
               else String
nn
      (Symbol String
oldname) = Define -> Symbol
defName Define
toRename
      newName :: Symbol
newName = String -> Symbol
Symbol (String -> Symbol) -> String -> Symbol
forall a b. (a -> b) -> a -> b
$ String -> Integer -> String
forall {a}. (Enum a, Ord a, Num a, Show a) => String -> a -> String
getNewName String
oldname (Integer
1 :: Integer)
  in Symbol -> Symbol -> [Define] -> [Define]
changeSym (Define -> Symbol
defName Define
toRename) Symbol
newName [Define]
inDefs


changeSym :: Symbol -> Symbol -> [Define] -> [Define]
changeSym :: Symbol -> Symbol -> [Define] -> [Define]
changeSym Symbol
old Symbol
new = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Symbol -> Symbol) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Symbol -> Symbol
chngSym)
  where
    chngSym :: Symbol -> Symbol
chngSym Symbol
s = Symbol -> Symbol -> Bool -> Symbol
forall a. a -> a -> Bool -> a
bool Symbol
s Symbol
new (Bool -> Symbol) -> Bool -> Symbol
forall a b. (a -> b) -> a -> b
$ Symbol
old Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
s

-- | Adjusts all unnamed metadata indices in the Module to begin at the specified
-- newBase, which allows this module to be combined without conflict with a
-- module whose metadata indices are all below the newBase.
updateUmd :: UnnamedMdIdx -> Module -> Module
updateUmd :: UnnamedMdIdx -> Module -> Module
updateUmd UnnamedMdIdx
newBase = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((UnnamedMdIdx -> UnnamedMdIdx) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (\UnnamedMdIdx
n -> UnnamedMdIdx
n UnnamedMdIdx -> UnnamedMdIdx -> UnnamedMdIdx
forall a. Num a => a -> a -> a
+ UnnamedMdIdx
newBase))