{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Llvm.MetaData
  ( MetaId(..)
  , ppMetaId
  , MetaExpr(..)
  , MetaAnnot(..)
  , MetaDecl(..)
    -- * Module flags
  , ModuleFlagBehavior(..)
  , ModuleFlag(..)
  , moduleFlagToMetaExpr
  ) where

import GHC.Prelude

import GHC.Llvm.Types
import GHC.Utils.Outputable

-- The LLVM Metadata System.
--
-- The LLVM metadata feature is poorly documented but roughly follows the
-- following design:
-- - Metadata can be constructed in a few different ways (See below).
-- - After which it can either be attached to LLVM statements to pass along
-- extra information to the optimizer and code generator OR specifically named
-- metadata has an affect on the whole module (i.e., linking behaviour).
--
--
-- # Constructing metadata
-- Metadata comes largely in three forms:
--
-- - Metadata expressions -- these are the raw metadata values that encode
--   information. They consist of metadata strings, metadata nodes, regular
--   LLVM values (both literals and references to global variables) and
--   metadata expressions (i.e., recursive data type). Some examples:
--     !{ !"hello", !0, i32 0 }
--     !{ !1, !{ i32 0 } }
--
-- - Metadata nodes -- global metadata variables that attach a metadata
--   expression to a number. For example:
--     !0 = !{ [<metadata expressions>] !}
--
-- - Named metadata -- global metadata variables that attach a metadata nodes
--   to a name. Used ONLY to communicated module level information to LLVM
--   through a meaningful name. For example:
--     !llvm.module.linkage = !{ !0, !1 }
--
--
-- # Using Metadata
-- Using metadata depends on the form it is in:
--
-- - Attach to instructions -- metadata can be attached to LLVM instructions
--   using a specific reference as follows:
--     %l = load i32* @glob, !nontemporal !10
--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
--   Only metadata nodes or expressions can be attached, named metadata cannot.
--   Refer to LLVM documentation for which instructions take metadata and its
--   meaning.
--
-- - As arguments -- llvm functions can take metadata as arguments, for
--   example:
--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
--   As with instructions, only metadata nodes or expressions can be attached.
--
-- - As a named metadata -- Here the metadata is simply declared in global
--   scope using a specific name to communicate module level information to LLVM.
--   For example:
--     !llvm.module.linkage = !{ !0, !1 }
--

-- | A reference to an un-named metadata node.
newtype MetaId = MetaId Int
               deriving (MetaId -> MetaId -> Bool
(MetaId -> MetaId -> Bool)
-> (MetaId -> MetaId -> Bool) -> Eq MetaId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetaId -> MetaId -> Bool
== :: MetaId -> MetaId -> Bool
$c/= :: MetaId -> MetaId -> Bool
/= :: MetaId -> MetaId -> Bool
Eq, Eq MetaId
Eq MetaId =>
(MetaId -> MetaId -> Ordering)
-> (MetaId -> MetaId -> Bool)
-> (MetaId -> MetaId -> Bool)
-> (MetaId -> MetaId -> Bool)
-> (MetaId -> MetaId -> Bool)
-> (MetaId -> MetaId -> MetaId)
-> (MetaId -> MetaId -> MetaId)
-> Ord MetaId
MetaId -> MetaId -> Bool
MetaId -> MetaId -> Ordering
MetaId -> MetaId -> MetaId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MetaId -> MetaId -> Ordering
compare :: MetaId -> MetaId -> Ordering
$c< :: MetaId -> MetaId -> Bool
< :: MetaId -> MetaId -> Bool
$c<= :: MetaId -> MetaId -> Bool
<= :: MetaId -> MetaId -> Bool
$c> :: MetaId -> MetaId -> Bool
> :: MetaId -> MetaId -> Bool
$c>= :: MetaId -> MetaId -> Bool
>= :: MetaId -> MetaId -> Bool
$cmax :: MetaId -> MetaId -> MetaId
max :: MetaId -> MetaId -> MetaId
$cmin :: MetaId -> MetaId -> MetaId
min :: MetaId -> MetaId -> MetaId
Ord, Int -> MetaId
MetaId -> Int
MetaId -> [MetaId]
MetaId -> MetaId
MetaId -> MetaId -> [MetaId]
MetaId -> MetaId -> MetaId -> [MetaId]
(MetaId -> MetaId)
-> (MetaId -> MetaId)
-> (Int -> MetaId)
-> (MetaId -> Int)
-> (MetaId -> [MetaId])
-> (MetaId -> MetaId -> [MetaId])
-> (MetaId -> MetaId -> [MetaId])
-> (MetaId -> MetaId -> MetaId -> [MetaId])
-> Enum MetaId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MetaId -> MetaId
succ :: MetaId -> MetaId
$cpred :: MetaId -> MetaId
pred :: MetaId -> MetaId
$ctoEnum :: Int -> MetaId
toEnum :: Int -> MetaId
$cfromEnum :: MetaId -> Int
fromEnum :: MetaId -> Int
$cenumFrom :: MetaId -> [MetaId]
enumFrom :: MetaId -> [MetaId]
$cenumFromThen :: MetaId -> MetaId -> [MetaId]
enumFromThen :: MetaId -> MetaId -> [MetaId]
$cenumFromTo :: MetaId -> MetaId -> [MetaId]
enumFromTo :: MetaId -> MetaId -> [MetaId]
$cenumFromThenTo :: MetaId -> MetaId -> MetaId -> [MetaId]
enumFromThenTo :: MetaId -> MetaId -> MetaId -> [MetaId]
Enum)

instance Outputable MetaId where
    ppr :: MetaId -> SDoc
ppr = MetaId -> SDoc
forall doc. IsLine doc => MetaId -> doc
ppMetaId

ppMetaId :: IsLine doc => MetaId -> doc
ppMetaId :: forall doc. IsLine doc => MetaId -> doc
ppMetaId (MetaId Int
n) = Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'!' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> doc
forall doc. IsLine doc => Int -> doc
int Int
n
{-# SPECIALIZE ppMetaId :: MetaId -> SDoc #-}
{-# SPECIALIZE ppMetaId :: MetaId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

-- | LLVM metadata expressions
data MetaExpr = MetaStr !LMString
              | MetaLit !LlvmLit
              | MetaNode !MetaId
              | MetaVar !LlvmVar
              | MetaStruct [MetaExpr]
              deriving (MetaExpr -> MetaExpr -> Bool
(MetaExpr -> MetaExpr -> Bool)
-> (MetaExpr -> MetaExpr -> Bool) -> Eq MetaExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetaExpr -> MetaExpr -> Bool
== :: MetaExpr -> MetaExpr -> Bool
$c/= :: MetaExpr -> MetaExpr -> Bool
/= :: MetaExpr -> MetaExpr -> Bool
Eq)

-- | Associates some metadata with a specific label for attaching to an
-- instruction.
data MetaAnnot = MetaAnnot LMString MetaExpr
               deriving (MetaAnnot -> MetaAnnot -> Bool
(MetaAnnot -> MetaAnnot -> Bool)
-> (MetaAnnot -> MetaAnnot -> Bool) -> Eq MetaAnnot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetaAnnot -> MetaAnnot -> Bool
== :: MetaAnnot -> MetaAnnot -> Bool
$c/= :: MetaAnnot -> MetaAnnot -> Bool
/= :: MetaAnnot -> MetaAnnot -> Bool
Eq)

-- | Metadata declarations. Metadata can only be declared in global scope.
data MetaDecl
    -- | Named metadata. Only used for communicating module information to
    -- LLVM. ('!name = !{ [!\<n>] }' form).
    = MetaNamed !LMString [MetaId]
    -- | Metadata node declaration.
    -- ('!0 = metadata !{ \<metadata expression> }' form).
    | MetaUnnamed !MetaId !MetaExpr

----------------------------------------------------------------
-- Module flags
----------------------------------------------------------------
data ModuleFlagBehavior
  = MFBError
  | MFBWarning
  | MFBRequire
  | MFBOverride
  | MFBAppend
  | MFBAppendUnique
  | MFBMax
  | MFBMin

moduleFlagBehaviorToMetaExpr :: ModuleFlagBehavior -> MetaExpr
moduleFlagBehaviorToMetaExpr :: ModuleFlagBehavior -> MetaExpr
moduleFlagBehaviorToMetaExpr ModuleFlagBehavior
mfb =
    LlvmLit -> MetaExpr
MetaLit (LlvmLit -> MetaExpr) -> LlvmLit -> MetaExpr
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
n LlvmType
i32
  where
    n :: Integer
n = case ModuleFlagBehavior
mfb of
      ModuleFlagBehavior
MFBError -> Integer
1
      ModuleFlagBehavior
MFBWarning -> Integer
2
      ModuleFlagBehavior
MFBRequire -> Integer
3
      ModuleFlagBehavior
MFBOverride -> Integer
4
      ModuleFlagBehavior
MFBAppend -> Integer
5
      ModuleFlagBehavior
MFBAppendUnique -> Integer
6
      ModuleFlagBehavior
MFBMax -> Integer
7
      ModuleFlagBehavior
MFBMin -> Integer
8

data ModuleFlag = ModuleFlag { ModuleFlag -> ModuleFlagBehavior
mfBehavior :: ModuleFlagBehavior
                             , ModuleFlag -> LMString
mfName :: LMString
                             , ModuleFlag -> MetaExpr
mfValue :: MetaExpr
                             }

moduleFlagToMetaExpr :: ModuleFlag -> MetaExpr
moduleFlagToMetaExpr :: ModuleFlag -> MetaExpr
moduleFlagToMetaExpr ModuleFlag
flag = [MetaExpr] -> MetaExpr
MetaStruct
    [ ModuleFlagBehavior -> MetaExpr
moduleFlagBehaviorToMetaExpr (ModuleFlag -> ModuleFlagBehavior
mfBehavior ModuleFlag
flag)
    , LMString -> MetaExpr
MetaStr (ModuleFlag -> LMString
mfName ModuleFlag
flag)
    , ModuleFlag -> MetaExpr
mfValue ModuleFlag
flag
    ]