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

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

#include "GhclibHsVersions.h"

import GHC.Prelude

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

import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Ppr

import GHC.Utils.BufHandle
import GHC.Driver.Session
import GHC.Platform ( platformArch, Arch(..) )
import GHC.Utils.Error
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.SysTools ( figureLlvmVersion )
import qualified GHC.Data.Stream as Stream

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

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: DynFlags -> Handle
               -> Stream.Stream IO RawCmmGroup a
               -> IO a
llvmCodeGen :: DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
llvmCodeGen DynFlags
dflags Handle
h Stream IO RawCmmGroup a
cmm_stream
  = DynFlags -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags (String -> SDoc
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
       BufHandle
bufh <- Handle -> IO BufHandle
newBufHandle Handle
h

       -- Pass header
       DynFlags -> String -> IO ()
showPass DynFlags
dflags String
"LLVM CodeGen"

       -- get llvm version, cache for later use
       Maybe LlvmVersion
mb_ver <- DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion DynFlags
dflags

       -- warn if unsupported
       Maybe LlvmVersion -> (LlvmVersion -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LlvmVersion
mb_ver ((LlvmVersion -> IO ()) -> IO ())
-> (LlvmVersion -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LlvmVersion
ver -> do
         DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2
              (String -> SDoc
text String
"Using LLVM version:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver))
         let doWarn :: Bool
doWarn = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsupportedLlvmVersion DynFlags
dflags
         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
$ DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
           SDoc
"You are using an unsupported version of LLVM!" SDoc -> SDoc -> SDoc
$$
           SDoc
"Currently only " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersion) SDoc -> SDoc -> SDoc
<> SDoc
" is supported." SDoc -> SDoc -> SDoc
<+>
           SDoc
"System LLVM version: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver) SDoc -> SDoc -> SDoc
$$
           SDoc
"We will try though..."
         let isS390X :: Bool
isS390X = Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchS390X
         let major_ver :: Int
major_ver = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> (LlvmVersion -> [Int]) -> LlvmVersion -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVersion -> [Int]
llvmVersionList (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
$ DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (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
<+>
           SDoc
"You are using LLVM version: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver)

       -- run code generation
       a
a <- DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
forall a. DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
runLlvm DynFlags
dflags (LlvmVersion -> Maybe LlvmVersion -> LlvmVersion
forall a. a -> Maybe a -> a
fromMaybe LlvmVersion
supportedLlvmVersion Maybe LlvmVersion
mb_ver) BufHandle
bufh (LlvmM a -> IO a) -> LlvmM a -> IO a
forall a b. (a -> b) -> a -> b
$
         DynFlags -> Stream LlvmM RawCmmGroup a -> LlvmM a
forall a. DynFlags -> Stream LlvmM RawCmmGroup a -> LlvmM a
llvmCodeGen' DynFlags
dflags (Stream IO RawCmmGroup a -> Stream LlvmM RawCmmGroup a
forall a x. Stream IO a x -> Stream LlvmM a x
liftStream Stream IO RawCmmGroup a
cmm_stream)

       BufHandle -> IO ()
bFlush BufHandle
bufh

       a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a
llvmCodeGen' :: DynFlags -> Stream LlvmM RawCmmGroup a -> LlvmM a
llvmCodeGen' DynFlags
dflags Stream LlvmM RawCmmGroup a
cmm_stream
  = do  -- Preamble
        SDoc -> LlvmM ()
renderLlvm SDoc
header
        LlvmM ()
ghcInternalFunctions
        LlvmM ()
cmmMetaLlvmPrelude

        -- Procedures
        a
a <- Stream LlvmM RawCmmGroup a -> (RawCmmGroup -> LlvmM ()) -> LlvmM a
forall (m :: * -> *) a b.
Monad m =>
Stream m a b -> (a -> m ()) -> m b
Stream.consume Stream LlvmM RawCmmGroup a
cmm_stream RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens

        -- Declare aliases for forward references
        LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
        SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> (LlvmData -> SDoc) -> LlvmData -> LlvmM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts (LlvmData -> LlvmM ()) -> LlvmM LlvmData -> LlvmM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LlvmM LlvmData
generateExternDecls

        -- Postamble
        LlvmM ()
cmmUsedLlvmGens

        a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  where
    header :: SDoc
    header :: SDoc
header =
      let target :: String
target = PlatformMisc -> String
platformMisc_llvmTarget (PlatformMisc -> String) -> PlatformMisc -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
      in     String -> SDoc
text (String
"target datalayout = \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LlvmConfig -> String -> String
getDataLayout (DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags) String
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
         SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text (String
"target triple = \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")

    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
text String
"Target:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
target SDoc -> SDoc -> SDoc
$$
                   SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Available targets:") Int
4
                        ([SDoc] -> SDoc
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
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)

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

        -- Insert functions into map, collect data
        let split :: GenCmmDecl b (map RawCmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split (CmmData Section
s b
d' )     = Maybe (Section, b) -> LlvmM (Maybe (Section, b))
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 map RawCmmStatics
h CLabel
l [GlobalReg]
live GenCmmGraph n
g) = do
              -- Set function type
              let l' :: CLabel
l' = case KeyOf map -> map RawCmmStatics -> Maybe RawCmmStatics
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph n -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph n
g) map RawCmmStatics
h :: Maybe RawCmmStatics of
                         Maybe RawCmmStatics
Nothing                   -> CLabel
l
                         Just (CmmStaticsRaw CLabel
info_lbl [CmmStatic]
_) -> CLabel
info_lbl
              LMString
lml <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
l'
              LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
lml (LlvmType -> LlvmM ()) -> LlvmM LlvmType -> LlvmM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [GlobalReg] -> LlvmM LlvmType
llvmFunTy [GlobalReg]
live
              Maybe (Section, b) -> LlvmM (Maybe (Section, b))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Section, b)
forall a. Maybe a
Nothing
        [(Section, RawCmmStatics)]
cdata <- ([Maybe (Section, RawCmmStatics)] -> [(Section, RawCmmStatics)])
-> LlvmM [Maybe (Section, RawCmmStatics)]
-> LlvmM [(Section, RawCmmStatics)]
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) (GenCmmGraph CmmNode)
 -> 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)
mapM GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
-> LlvmM (Maybe (Section, RawCmmStatics))
forall (map :: * -> *) b
       (n :: Extensibility -> Extensibility -> *).
(IsMap map, KeyOf map ~ BlockId) =>
GenCmmDecl b (map RawCmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split RawCmmGroup
cmm

        {-# SCC "llvm_datas_gen" #-}
          [(Section, RawCmmStatics)] -> LlvmM ()
cmmDataLlvmGens [(Section, RawCmmStatics)]
cdata
        {-# SCC "llvm_procs_gen" #-}
          (GenCmmDecl
   RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
 -> LlvmM ())
-> RawCmmGroup -> LlvmM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
-> LlvmM ()
cmmLlvmGen RawCmmGroup
cmm

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

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

       let ([[LMGlobal]] -> [LMGlobal]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [LMGlobal]
gs, [[LlvmType]]
tss) = [LlvmData] -> ([[LMGlobal]], [[LlvmType]])
forall a b. [(a, b)] -> ([a], [b])
unzip [LlvmData]
lmdatas

       let regGlobal :: LMGlobal -> LlvmM ()
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
       (LMGlobal -> LlvmM ()) -> [LMGlobal] -> LlvmM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LMGlobal -> LlvmM ()
regGlobal [LMGlobal]
gs
       [[LMGlobal]]
gss' <- (LMGlobal -> LlvmM [LMGlobal]) -> [LMGlobal] -> LlvmM [[LMGlobal]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LMGlobal -> LlvmM [LMGlobal]
aliasify ([LMGlobal] -> LlvmM [[LMGlobal]])
-> [LMGlobal] -> LlvmM [[LMGlobal]]
forall a b. (a -> b) -> a -> b
$ [LMGlobal]
gs

       LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
       SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts ([[LMGlobal]] -> [LMGlobal]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LMGlobal]]
gss', [[LlvmType]] -> [LlvmType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmType]]
tss)

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

    -- rewrite assignments to global regs
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let fixed_cmm :: GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
fixed_cmm = {-# SCC "llvm_fix_regs" #-} DynFlags
-> GenCmmDecl
     RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
-> GenCmmDecl
     RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
fixStgRegisters DynFlags
dflags GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
cmm

    DumpFlag -> String -> DumpFormat -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_opt_cmm String
"Optimised Cmm"
      DumpFormat
FormatCMM (RawCmmGroup -> SDoc
forall d info g.
(Outputable d, Outputable info, Outputable g) =>
GenCmmGroup d info g -> SDoc
pprCmmGroup [GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
fixed_cmm])

    -- generate llvm code from cmm
    [LlvmCmmDecl]
llvmBC <- LlvmM [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall a. LlvmM a -> LlvmM a
withClearVars (LlvmM [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl])
-> LlvmM [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall a b. (a -> b) -> a -> b
$ GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
-> LlvmM [LlvmCmmDecl]
genLlvmProc GenCmmDecl
  RawCmmStatics (LabelMap RawCmmStatics) (GenCmmGraph CmmNode)
fixed_cmm

    -- pretty print
    ([SDoc]
docs, [[LlvmVar]]
ivars) <- ([(SDoc, [LlvmVar])] -> ([SDoc], [[LlvmVar]]))
-> LlvmM [(SDoc, [LlvmVar])] -> LlvmM ([SDoc], [[LlvmVar]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(SDoc, [LlvmVar])] -> ([SDoc], [[LlvmVar]])
forall a b. [(a, b)] -> ([a], [b])
unzip (LlvmM [(SDoc, [LlvmVar])] -> LlvmM ([SDoc], [[LlvmVar]]))
-> LlvmM [(SDoc, [LlvmVar])] -> LlvmM ([SDoc], [[LlvmVar]])
forall a b. (a -> b) -> a -> b
$ (LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]))
-> [LlvmCmmDecl] -> LlvmM [(SDoc, [LlvmVar])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl [LlvmCmmDecl]
llvmBC

    -- Output, note down used variables
    SDoc -> LlvmM ()
renderLlvm ([SDoc] -> SDoc
vcat [SDoc]
docs)
    (LlvmVar -> LlvmM ()) -> [LlvmVar] -> LlvmM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LlvmVar -> LlvmM ()
markUsedVar ([LlvmVar] -> LlvmM ()) -> [LlvmVar] -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ [[LlvmVar]] -> [LlvmVar]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmVar]]
ivars

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

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

cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
  [MetaDecl]
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)
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
    MetaId
tbaaId <- LlvmM MetaId
getMetaUniqueId
    Unique -> MetaId -> LlvmM ()
setUniqMeta Unique
uniq MetaId
tbaaId
    Maybe MetaId
parentId <- LlvmM (Maybe MetaId)
-> (Unique -> LlvmM (Maybe MetaId))
-> Maybe Unique
-> LlvmM (Maybe MetaId)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe MetaId -> LlvmM (Maybe MetaId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MetaId
forall a. Maybe a
Nothing) Unique -> LlvmM (Maybe MetaId)
getUniqMeta Maybe Unique
parent
    -- Build definition
    MetaDecl -> LlvmM MetaDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (MetaDecl -> LlvmM MetaDecl) -> MetaDecl -> LlvmM MetaDecl
forall a b. (a -> b) -> a -> b
$ MetaId -> MetaExpr -> MetaDecl
MetaUnnamed MetaId
tbaaId (MetaExpr -> MetaDecl) -> MetaExpr -> MetaDecl
forall a b. (a -> b) -> a -> b
$ [MetaExpr] -> MetaExpr
MetaStruct ([MetaExpr] -> MetaExpr) -> [MetaExpr] -> MetaExpr
forall a b. (a -> b) -> a -> b
$
          case Maybe MetaId
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 ]
  LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
  SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> [MetaDecl] -> SDoc
ppLlvmMetas LlvmOpts
opts [MetaDecl]
metas

-- -----------------------------------------------------------------------------
-- | 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.
  [LlvmVar]
ivars <- LlvmM [LlvmVar]
getUsedVars
  let cast :: LlvmVar -> LlvmStatic
cast LlvmVar
x = LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer (LlvmVar -> LlvmVar
pVarLift LlvmVar
x)) LlvmType
i8Ptr
      ty :: LlvmType
ty     = (Int -> LlvmType -> LlvmType
LMArray ([LlvmVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LlvmVar]
ivars) LlvmType
i8Ptr)
      usedArray :: LlvmStatic
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 :: LMSection
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 :: LlvmVar
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 :: LMGlobal
lmUsed    = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
lmUsedVar (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just LlvmStatic
usedArray)
  LlvmOpts
opts <- LlvmM LlvmOpts
getLlvmOpts
  if [LlvmVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmVar]
ivars
     then () -> LlvmM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmData -> SDoc
pprLlvmData LlvmOpts
opts ([LMGlobal
lmUsed], [])