{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}

-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--
module GHC.CmmToLlvm
   ( LlvmVersion
   , llvmVersionList
   , llvmCodeGen
   , llvmFixupAsm
   )
where

import GHC.Prelude hiding ( head )

import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.CodeGen
import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Data
import GHC.CmmToLlvm.Ppr
import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Mangler
import GHC.CmmToLlvm.Version

import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream )
import GHC.Cmm
import GHC.Cmm.Dataflow.Label

import GHC.Types.Unique.DSM
import GHC.Utils.BufHandle
import GHC.Driver.DynFlags
import GHC.Platform ( platformArch, Arch(..) )
import GHC.Utils.Error
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import qualified GHC.Data.Stream as Stream

import Control.Monad ( when, forM_ )
import Data.List.NonEmpty ( head )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: Logger -> LlvmCgConfig -> Handle
            -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream.
                           -- See Note [Deterministic Uniques in the CG]
            -> CgStream RawCmmGroup a
            -> IO a
llvmCodeGen :: forall a.
Logger
-> LlvmCgConfig
-> Handle
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
llvmCodeGen Logger
logger LlvmCgConfig
cfg Handle
h DUniqSupply
dus CgStream RawCmmGroup a
cmm_stream
  = Logger -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"LLVM CodeGen") (() -> a -> ()
forall a b. a -> b -> a
const ()) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
       bufh <- Handle -> IO BufHandle
newBufHandle Handle
h

       -- Pass header
       showPass logger "LLVM CodeGen"

       -- get llvm version, cache for later use
       let mb_ver = LlvmCgConfig -> Maybe LlvmVersion
llvmCgLlvmVersion LlvmCgConfig
cfg

       -- warn if unsupported
       forM_ mb_ver $ \LlvmVersion
ver -> do
         Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Using LLVM version:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver))
         let doWarn :: Bool
doWarn = LlvmCgConfig -> Bool
llvmCgDoWarn LlvmCgConfig
cfg
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (LlvmVersion -> Bool
llvmVersionSupported LlvmVersion
ver) Bool -> Bool -> Bool
&& Bool
doWarn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
           SDoc
"You are using an unsupported version of LLVM!" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           SDoc
"Currently only" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionLowerBound) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           SDoc
"up to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionUpperBound) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
"(non inclusive) is supported." SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           SDoc
"System LLVM version: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           SDoc
"We will try though..."
         let isS390X :: Bool
isS390X = Platform -> Arch
platformArch (LlvmCgConfig -> Platform
llvmCgPlatform LlvmCgConfig
cfg)  Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchS390X
         let major_ver :: Int
major_ver = NonEmpty Int -> Int
forall a. NonEmpty a -> a
head (NonEmpty Int -> Int)
-> (LlvmVersion -> NonEmpty Int) -> LlvmVersion -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> NonEmpty Int
llvmVersionNE (LlvmVersion -> Int) -> LlvmVersion -> Int
forall a b. (a -> b) -> a -> b
$ LlvmVersion
ver
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isS390X Bool -> Bool -> Bool
&& Int
major_ver Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Bool -> Bool -> Bool
&& Bool
doWarn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
           SDoc
"Warning: For s390x the GHC calling convention is only supported since LLVM version 10." SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
           SDoc
"You are using LLVM version: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver)

       -- HACK: the Nothing case here is potentially wrong here but we
       -- currently don't use the LLVM version to guide code generation
       -- so this is okay.
       let llvm_ver :: LlvmVersion
           llvm_ver = LlvmVersion -> Maybe LlvmVersion -> LlvmVersion
forall a. a -> Maybe a -> a
fromMaybe LlvmVersion
supportedLlvmVersionLowerBound Maybe LlvmVersion
mb_ver

       -- run code generation
       (a, _) <- runLlvm logger cfg llvm_ver bufh dus $
         llvmCodeGen' cfg cmm_stream

       bFlush bufh

       return a

llvmCodeGen' :: LlvmCgConfig
             -> CgStream RawCmmGroup a -> LlvmM a
llvmCodeGen' :: forall a. LlvmCgConfig -> CgStream RawCmmGroup a -> LlvmM a
llvmCodeGen' LlvmCgConfig
cfg CgStream RawCmmGroup a
cmm_stream
  = do  -- Preamble
        HDoc -> SDoc -> LlvmM ()
renderLlvm (LlvmCgConfig -> HDoc
forall doc. IsDoc doc => LlvmCgConfig -> doc
llvmHeader LlvmCgConfig
cfg) (LlvmCgConfig -> SDoc
forall doc. IsDoc doc => LlvmCgConfig -> doc
llvmHeader LlvmCgConfig
cfg)
        LlvmM ()
ghcInternalFunctions
        LlvmM ()
cmmMetaLlvmPrelude

        -- Procedures
        a <- CgStream RawCmmGroup a
-> (forall a1. UniqDSMT IO a1 -> LlvmM a1)
-> (RawCmmGroup -> LlvmM ())
-> LlvmM a
forall (m :: * -> *) (n :: * -> *) a b.
(Monad m, Monad n) =>
Stream m a b -> (forall a1. m a1 -> n a1) -> (a -> n ()) -> n b
Stream.consume CgStream RawCmmGroup a
cmm_stream (UniqDSMT IO a1 -> LlvmM a1
forall a1. UniqDSMT IO a1 -> LlvmM a1
GHC.CmmToLlvm.Base.liftUDSMT) (RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens)

        -- Declare aliases for forward references
        decls <- generateExternDecls
        renderLlvm (pprLlvmData cfg decls)
                   (pprLlvmData cfg decls)

        -- Postamble
        cmmUsedLlvmGens

        return a

llvmHeader :: IsDoc doc => LlvmCgConfig -> doc
llvmHeader :: forall doc. IsDoc doc => LlvmCgConfig -> doc
llvmHeader LlvmCgConfig
cfg =
  let target :: String
target  = LlvmCgConfig -> String
llvmCgLlvmTarget LlvmCgConfig
cfg
      llvmCfg :: LlvmConfig
llvmCfg = LlvmCgConfig -> LlvmConfig
llvmCgLlvmConfig LlvmCgConfig
cfg
  in [Line doc] -> doc
forall doc. IsDoc doc => [Line doc] -> doc
lines_
      [ String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"target datalayout = \"" Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> Line doc
forall doc. IsLine doc => String -> doc
text (LlvmConfig -> String -> String
getDataLayout LlvmConfig
llvmCfg String
target) Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"\""
      , String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"target triple = \"" Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> Line doc
forall doc. IsLine doc => String -> doc
text String
target Line doc -> Line doc -> Line doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> Line doc
forall doc. IsLine doc => String -> doc
text String
"\"" ]
  where
    getDataLayout :: LlvmConfig -> String -> String
    getDataLayout :: LlvmConfig -> String -> String
getDataLayout LlvmConfig
config String
target =
      case String -> [(String, LlvmTarget)] -> Maybe LlvmTarget
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
target (LlvmConfig -> [(String, LlvmTarget)]
llvmTargets LlvmConfig
config) of
        Just (LlvmTarget {lDataLayout :: LlvmTarget -> String
lDataLayout=String
dl}) -> String
dl
        Maybe LlvmTarget
Nothing -> String -> SDoc -> String
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Failed to lookup LLVM data layout" (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
                   String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Target:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
target SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                   SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Available targets:") Int
4
                        ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((String, LlvmTarget) -> SDoc) -> [(String, LlvmTarget)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> ((String, LlvmTarget) -> String) -> (String, LlvmTarget) -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, LlvmTarget) -> String
forall a b. (a, b) -> a
fst) ([(String, LlvmTarget)] -> [SDoc])
-> [(String, LlvmTarget)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ LlvmConfig -> [(String, LlvmTarget)]
llvmTargets LlvmConfig
config)
{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-}
{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens RawCmmGroup
cmm = do

        -- Insert functions into map, collect data
        let split :: GenCmmDecl b (LabelMap RawCmmStatics) (GenGenCmmGraph s n)
-> LlvmM (Maybe (Section, b))
split (CmmData Section
s b
d' )     = Maybe (Section, b) -> LlvmM (Maybe (Section, b))
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Section, b) -> LlvmM (Maybe (Section, b)))
-> Maybe (Section, b) -> LlvmM (Maybe (Section, b))
forall a b. (a -> b) -> a -> b
$ (Section, b) -> Maybe (Section, b)
forall a. a -> Maybe a
Just (Section
s, b
d')
            split (CmmProc LabelMap RawCmmStatics
h CLabel
l [GlobalRegUse]
live GenGenCmmGraph s n
g) = do
              -- Set function type
              let l' :: CLabel
l' = case Label -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. Label -> LabelMap a -> Maybe a
mapLookup (GenGenCmmGraph s n -> Label
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> Label
g_entry GenGenCmmGraph s n
g) LabelMap RawCmmStatics
h :: Maybe RawCmmStatics of
                         Maybe RawCmmStatics
Nothing                   -> CLabel
l
                         Just (CmmStaticsRaw CLabel
info_lbl [CmmStatic]
_) -> CLabel
info_lbl
              lml <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
l'
              funInsert lml =<< llvmFunTy live
              return Nothing
        cdata <- ([Maybe (Section, RawCmmStatics)] -> [(Section, RawCmmStatics)])
-> LlvmM [Maybe (Section, RawCmmStatics)]
-> LlvmM [(Section, RawCmmStatics)]
forall a b. (a -> b) -> LlvmM a -> LlvmM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Section, RawCmmStatics)] -> [(Section, RawCmmStatics)]
forall a. [Maybe a] -> [a]
catMaybes (LlvmM [Maybe (Section, RawCmmStatics)]
 -> LlvmM [(Section, RawCmmStatics)])
-> LlvmM [Maybe (Section, RawCmmStatics)]
-> LlvmM [(Section, RawCmmStatics)]
forall a b. (a -> b) -> a -> b
$ (GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
 -> LlvmM (Maybe (Section, RawCmmStatics)))
-> RawCmmGroup -> LlvmM [Maybe (Section, RawCmmStatics)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> LlvmM (Maybe (Section, RawCmmStatics))
forall {b} {s :: * -> *}
       {n :: Extensibility -> Extensibility -> *}.
GenCmmDecl b (LabelMap RawCmmStatics) (GenGenCmmGraph s n)
-> LlvmM (Maybe (Section, b))
split RawCmmGroup
cmm

        {-# SCC "llvm_datas_gen" #-}
          cmmDataLlvmGens cdata
        {-# SCC "llvm_procs_gen" #-}
          mapM_ cmmLlvmGen cmm

-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
--
cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM ()

cmmDataLlvmGens :: [(Section, RawCmmStatics)] -> LlvmM ()
cmmDataLlvmGens [(Section, RawCmmStatics)]
statics
  = do lmdatas <- ((Section, RawCmmStatics) -> LlvmM ([LMGlobal], [LlvmType]))
-> [(Section, RawCmmStatics)] -> LlvmM [([LMGlobal], [LlvmType])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Section, RawCmmStatics) -> LlvmM ([LMGlobal], [LlvmType])
genLlvmData [(Section, RawCmmStatics)]
statics

       let (concat -> gs, tss) = unzip lmdatas

       let regGlobal (LMGlobal (LMGlobalVar LMString
l LlvmType
ty LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) Maybe LlvmStatic
_)
                        = LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
l LlvmType
ty
           regGlobal LMGlobal
_  = () -> LlvmM ()
forall a. a -> LlvmM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       mapM_ regGlobal gs
       gss' <- mapM aliasify gs

       cfg <- getConfig
       renderLlvm (pprLlvmData cfg (concat gss', concat tss))
                  (pprLlvmData cfg (concat gss', concat tss))

-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen :: GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> LlvmM ()
cmmLlvmGen cmm :: GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
cmm@CmmProc{} = do

    -- rewrite assignments to global regs
    platform <- LlvmM Platform
getPlatform
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} Platform
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
fixStgRegisters Platform
platform GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
cmm

    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
      FormatCMM (pprCmmGroup platform [fixed_cmm])

    -- generate llvm code from cmm
    llvmBC <- withClearVars $ genLlvmProc fixed_cmm

    -- pretty print - print as we go, since we produce HDocs, we know
    -- no nesting state needs to be maintained for the SDocs.
    forM_ llvmBC (\LlvmCmmDecl
decl -> do
        (hdoc, sdoc) <- LlvmCmmDecl -> LlvmM (HDoc, SDoc)
pprLlvmCmmDecl LlvmCmmDecl
decl
        renderLlvm (hdoc $$ empty) (sdoc $$ empty)
      )

cmmLlvmGen GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
_ = () -> LlvmM ()
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- -----------------------------------------------------------------------------
-- | Generate meta data nodes
--

cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
  tbaa_metas <- (((Unique, LMString, Maybe Unique) -> LlvmM MetaDecl)
 -> [(Unique, LMString, Maybe Unique)] -> LlvmM [MetaDecl])
-> [(Unique, LMString, Maybe Unique)]
-> ((Unique, LMString, Maybe Unique) -> LlvmM MetaDecl)
-> LlvmM [MetaDecl]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Unique, LMString, Maybe Unique) -> LlvmM MetaDecl)
-> [(Unique, LMString, Maybe Unique)] -> LlvmM [MetaDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [(Unique, LMString, Maybe Unique)]
stgTBAA (((Unique, LMString, Maybe Unique) -> LlvmM MetaDecl)
 -> LlvmM [MetaDecl])
-> ((Unique, LMString, Maybe Unique) -> LlvmM MetaDecl)
-> LlvmM [MetaDecl]
forall a b. (a -> b) -> a -> b
$ \(Unique
uniq, LMString
name, Maybe Unique
parent) -> do
    -- Generate / lookup meta data IDs
    tbaaId <- LlvmM MetaId
getMetaUniqueId
    setUniqMeta uniq tbaaId
    parentId <- maybe (return Nothing) getUniqMeta parent
    -- Build definition
    return $ MetaUnnamed tbaaId $ MetaStruct $
          case parentId of
              Just MetaId
p  -> [ LMString -> MetaExpr
MetaStr LMString
name, MetaId -> MetaExpr
MetaNode MetaId
p ]
              -- As of LLVM 4.0, a node without parents should be rendered as
              -- just a name on its own. Previously `null` was accepted as the
              -- name.
              Maybe MetaId
Nothing -> [ LMString -> MetaExpr
MetaStr LMString
name ]

  platform <- getPlatform
  cfg <- getConfig
  let stack_alignment_metas =
          case Platform -> Arch
platformArch Platform
platform of
            Arch
ArchX86_64 | LlvmCgConfig -> Bool
llvmCgAvxEnabled LlvmCgConfig
cfg -> [Integer -> ModuleFlag
mkStackAlignmentMeta Integer
32]
            Arch
_                                 -> []
  module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas
  let metas = [MetaDecl]
tbaa_metas [MetaDecl] -> [MetaDecl] -> [MetaDecl]
forall a. [a] -> [a] -> [a]
++ [MetaDecl]
module_flags_metas
  cfg <- getConfig
  renderLlvm (ppLlvmMetas cfg metas)
             (ppLlvmMetas cfg metas)

mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl]
mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl]
mkNamedMeta LMString
name [MetaExpr]
exprs = do
    (ids, decls) <- [(MetaId, MetaDecl)] -> ([MetaId], [MetaDecl])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(MetaId, MetaDecl)] -> ([MetaId], [MetaDecl]))
-> LlvmM [(MetaId, MetaDecl)] -> LlvmM ([MetaId], [MetaDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaExpr -> LlvmM (MetaId, MetaDecl))
-> [MetaExpr] -> LlvmM [(MetaId, MetaDecl)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM MetaExpr -> LlvmM (MetaId, MetaDecl)
f [MetaExpr]
exprs
    return $ decls ++ [MetaNamed name ids]
  where
    f :: MetaExpr -> LlvmM (MetaId, MetaDecl)
f MetaExpr
expr = do
      i <- LlvmM MetaId
getMetaUniqueId
      return (i, MetaUnnamed i expr)

mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl]
mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl]
mkModuleFlagsMeta =
    LMString -> [MetaExpr] -> LlvmM [MetaDecl]
mkNamedMeta LMString
"llvm.module.flags" ([MetaExpr] -> LlvmM [MetaDecl])
-> ([ModuleFlag] -> [MetaExpr]) -> [ModuleFlag] -> LlvmM [MetaDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleFlag -> MetaExpr) -> [ModuleFlag] -> [MetaExpr]
forall a b. (a -> b) -> [a] -> [b]
map ModuleFlag -> MetaExpr
moduleFlagToMetaExpr

mkStackAlignmentMeta :: Integer -> ModuleFlag
mkStackAlignmentMeta :: Integer -> ModuleFlag
mkStackAlignmentMeta Integer
alignment =
    ModuleFlagBehavior -> LMString -> MetaExpr -> ModuleFlag
ModuleFlag ModuleFlagBehavior
MFBError LMString
"override-stack-alignment" (LlvmLit -> MetaExpr
MetaLit (LlvmLit -> MetaExpr) -> LlvmLit -> MetaExpr
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
alignment LlvmType
i32)


-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
--

cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens = do

  -- LLVM would discard variables that are internal and not obviously
  -- used if we didn't provide these hints. This will generate a
  -- definition of the form
  --
  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
  --
  -- Which is the LLVM way of protecting them against getting removed.
  ivars <- LlvmM [LlvmVar]
getUsedVars
  let cast LlvmVar
x = LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer (LlvmVar -> LlvmVar
pVarLift LlvmVar
x)) LlvmType
i8Ptr
      ty     = Int -> LlvmType -> LlvmType
LMArray ([LlvmVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LlvmVar]
ivars) LlvmType
i8Ptr
      usedArray = [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticArray ((LlvmVar -> LlvmStatic) -> [LlvmVar] -> [LlvmStatic]
forall a b. (a -> b) -> [a] -> [b]
map LlvmVar -> LlvmStatic
cast [LlvmVar]
ivars) LlvmType
ty
      sectName  = LMString -> LMSection
forall a. a -> Maybe a
Just (LMString -> LMSection) -> LMString -> LMSection
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit String
"llvm.metadata"
      lmUsedVar = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar (String -> LMString
fsLit String
"llvm.used") LlvmType
ty LlvmLinkageType
Appending LMSection
sectName LMAlign
forall a. Maybe a
Nothing LMConst
Constant
      lmUsed    = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
lmUsedVar (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just LlvmStatic
usedArray)
  if null ivars
     then return ()
     else do
      cfg <- getConfig
      renderLlvm (pprLlvmData cfg ([lmUsed], []))
                 (pprLlvmData cfg ([lmUsed], []))