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

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

#include "HsVersions.h"

import GhcPrelude

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
import LlvmCodeGen.Regs
import LlvmMangler

import BlockId
import CgUtils ( fixStgRegisters )
import Cmm
import CmmUtils
import Hoopl.Block
import Hoopl.Collections
import PprCmm

import BufWrite
import DynFlags
import ErrUtils
import FastString
import Outputable
import UniqSupply
import SysTools ( figureLlvmVersion )
import qualified Stream

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

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
               -> Stream.Stream IO RawCmmGroup ()
               -> IO ()
llvmCodeGen :: DynFlags
-> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
llvmCodeGen dflags :: DynFlags
dflags h :: Handle
h us :: UniqSupply
us cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream
  = IO DynFlags -> SDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags) (String -> SDoc
text "LLVM CodeGen") (() -> () -> ()
forall a b. a -> b -> a
const ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
       BufHandle
bufh <- Handle -> IO BufHandle
newBufHandle Handle
h

       -- Pass header
       DynFlags -> String -> IO ()
showPass DynFlags
dflags "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
$ \ver :: LlvmVersion
ver -> do
         DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2
              (String -> SDoc
text "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
$
           "You are using an unsupported version of LLVM!" SDoc -> SDoc -> SDoc
$$
           "Currently only " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersion) SDoc -> SDoc -> SDoc
<> " is supported." SDoc -> SDoc -> SDoc
<+>
           "System LLVM version: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text (LlvmVersion -> String
llvmVersionStr LlvmVersion
ver) SDoc -> SDoc -> SDoc
$$
           "We will try though..."

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

       BufHandle -> IO ()
bFlush BufHandle
bufh

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

        -- Procedures
        let llvmStream :: Stream LlvmM () ()
llvmStream = (RawCmmGroup -> LlvmM ())
-> Stream LlvmM RawCmmGroup () -> Stream LlvmM () ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens Stream LlvmM RawCmmGroup ()
cmm_stream
        [()]
_ <- Stream LlvmM () () -> LlvmM [()]
forall (m :: * -> *) a. Monad m => Stream m a () -> m [a]
Stream.collect Stream LlvmM () ()
llvmStream

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

        -- Postamble
        LlvmM ()
cmmUsedLlvmGens
  where
    header :: SDoc
    header :: SDoc
header = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
      let target :: String
target = LLVM_TARGET
          layout :: String
layout = case String -> [(String, LlvmTarget)] -> Maybe LlvmTarget
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
target (DynFlags -> [(String, LlvmTarget)]
llvmTargets DynFlags
dflags) of
            Just (LlvmTarget dl :: String
dl _ _) -> String
dl
            Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Failed to lookup the datalayout for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; available targets: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (((String, LlvmTarget) -> String)
-> [(String, LlvmTarget)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, LlvmTarget) -> String
forall a b. (a, b) -> a
fst ([(String, LlvmTarget)] -> [String])
-> [(String, LlvmTarget)] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [(String, LlvmTarget)]
llvmTargets DynFlags
dflags)
      in     String -> SDoc
text ("target datalayout = \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
layout String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"")
         SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ("target triple = \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"")

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

        -- Insert functions into map, collect data
        let split :: GenCmmDecl b (map CmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split (CmmData s :: Section
s d' :: 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 h :: map CmmStatics
h l :: CLabel
l live :: [GlobalReg]
live g :: GenCmmGraph n
g) = do
              -- Set function type
              let l' :: CLabel
l' = case KeyOf map -> map CmmStatics -> Maybe CmmStatics
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph n -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry GenCmmGraph n
g) map CmmStatics
h of
                         Nothing                   -> CLabel
l
                         Just (Statics info_lbl :: CLabel
info_lbl _) -> 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, CmmStatics)]
cdata <- ([Maybe (Section, CmmStatics)] -> [(Section, CmmStatics)])
-> LlvmM [Maybe (Section, CmmStatics)]
-> LlvmM [(Section, CmmStatics)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Section, CmmStatics)] -> [(Section, CmmStatics)]
forall a. [Maybe a] -> [a]
catMaybes (LlvmM [Maybe (Section, CmmStatics)]
 -> LlvmM [(Section, CmmStatics)])
-> LlvmM [Maybe (Section, CmmStatics)]
-> LlvmM [(Section, CmmStatics)]
forall a b. (a -> b) -> a -> b
$ (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
 -> LlvmM (Maybe (Section, CmmStatics)))
-> RawCmmGroup -> LlvmM [Maybe (Section, CmmStatics)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM (Maybe (Section, CmmStatics))
forall (map :: * -> *) b (n :: * -> * -> *).
(IsMap map, KeyOf map ~ BlockId) =>
GenCmmDecl b (map CmmStatics) (GenCmmGraph n)
-> LlvmM (Maybe (Section, b))
split RawCmmGroup
cmm

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

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

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

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

       let regGlobal :: LMGlobal -> LlvmM ()
regGlobal (LMGlobal (LMGlobalVar l :: LMString
l ty :: LlvmType
ty _ _ _ _) _)
                        = LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
l LlvmType
ty
           regGlobal _  = () -> 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

       SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmData -> SDoc
pprLlvmData ([[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)

-- | LLVM can't handle entry blocks which loop back to themselves (could be
-- seen as an LLVM bug) so we rearrange the code to keep the original entry
-- label which branches to a newly generated second label that branches back
-- to itself. See: Trac #11649
fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
fixBottom :: GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
fixBottom cp :: GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
cp@(CmmProc hdr :: LabelMap CmmStatics
hdr entry_lbl :: CLabel
entry_lbl live :: [GlobalReg]
live g :: GenCmmGraph CmmNode
g) =
    LlvmM
  (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
-> (CmmBlock
    -> LlvmM
         (GenCmmDecl
            CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)))
-> Maybe CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
cp) CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
fix_block (Maybe CmmBlock
 -> LlvmM
      (GenCmmDecl
         CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)))
-> Maybe CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph CmmNode -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g) LabelMap CmmBlock
blk_map
  where
    blk_map :: LabelMap CmmBlock
blk_map = GenCmmGraph CmmNode -> LabelMap CmmBlock
toBlockMap GenCmmGraph CmmNode
g

    fix_block :: CmmBlock -> LlvmM RawCmmDecl
    fix_block :: CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
fix_block blk :: CmmBlock
blk
        | (CmmEntry e_lbl :: BlockId
e_lbl tickscp :: CmmTickScope
tickscp, middle :: Block CmmNode O O
middle, CmmBranch b_lbl :: BlockId
b_lbl) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
blk
        , Block CmmNode O O -> Bool
forall (n :: * -> * -> *) e x. Block n e x -> Bool
isEmptyBlock Block CmmNode O O
middle
        , BlockId
e_lbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
b_lbl = do
            BlockId
new_lbl <- Unique -> BlockId
mkBlockId (Unique -> BlockId) -> LlvmM Unique -> LlvmM BlockId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LlvmM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM

            let fst_blk :: CmmBlock
fst_blk =
                    CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: * -> * -> *).
n C O -> Block n O O -> n O C -> Block n C C
BlockCC (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
e_lbl CmmTickScope
tickscp) Block CmmNode O O
forall (n :: * -> * -> *). Block n O O
BNil (BlockId -> CmmNode O C
CmmBranch BlockId
new_lbl)
                snd_blk :: CmmBlock
snd_blk =
                    CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: * -> * -> *).
n C O -> Block n O O -> n O C -> Block n C C
BlockCC (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
new_lbl CmmTickScope
tickscp) Block CmmNode O O
forall (n :: * -> * -> *). Block n O O
BNil (BlockId -> CmmNode O C
CmmBranch BlockId
new_lbl)

            GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
 -> LlvmM
      (GenCmmDecl
         CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)))
-> (LabelMap CmmBlock
    -> GenCmmDecl
         CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
-> LabelMap CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> GenCmmGraph CmmNode
-> GenCmmDecl
     CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
hdr CLabel
entry_lbl [GlobalReg]
live (GenCmmGraph CmmNode
 -> GenCmmDecl
      CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
-> (LabelMap CmmBlock -> GenCmmGraph CmmNode)
-> LabelMap CmmBlock
-> GenCmmDecl
     CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> LabelMap CmmBlock -> GenCmmGraph CmmNode
ofBlockMap (GenCmmGraph CmmNode -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g)
                (LabelMap CmmBlock
 -> LlvmM
      (GenCmmDecl
         CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)))
-> LabelMap CmmBlock
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall a b. (a -> b) -> a -> b
$ [(KeyOf LabelMap, CmmBlock)] -> LabelMap CmmBlock
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(KeyOf LabelMap
BlockId
e_lbl, CmmBlock
fst_blk), (KeyOf LabelMap
BlockId
new_lbl, CmmBlock
snd_blk)]

    fix_block _ = GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
cp

fixBottom rcd :: GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
rcd = GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
rcd

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

    -- rewrite assignments to global regs
    DynFlags
dflags <- (DynFlags -> DynFlags) -> LlvmM DynFlags
forall a. (DynFlags -> a) -> LlvmM a
getDynFlag DynFlags -> DynFlags
forall a. a -> a
id
    GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
fixed_cmm <- GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
fixBottom (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
 -> LlvmM
      (GenCmmDecl
         CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)))
-> GenCmmDecl
     CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM
     (GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode))
forall a b. (a -> b) -> a -> b
$
                    {-# SCC "llvm_fix_regs" #-}
                    DynFlags
-> GenCmmDecl
     CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> GenCmmDecl
     CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
fixStgRegisters DynFlags
dflags GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
cmm

    DumpFlag -> String -> SDoc -> LlvmM ()
dumpIfSetLlvm DumpFlag
Opt_D_dump_opt_cmm "Optimised Cmm" (RawCmmGroup -> SDoc
forall d info g.
(Outputable d, Outputable info, Outputable g) =>
GenCmmGroup d info g -> SDoc
pprCmmGroup [GenCmmDecl CmmStatics (LabelMap CmmStatics) (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 CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
-> LlvmM [LlvmCmmDecl]
genLlvmProc GenCmmDecl CmmStatics (LabelMap CmmStatics) (GenCmmGraph CmmNode)
fixed_cmm

    -- pretty print
    (docs :: [SDoc]
docs, ivars :: [[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 _ = () -> 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
$ \(uniq :: Unique
uniq, name :: LMString
name, parent :: 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 p :: 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.
              Nothing -> [ LMString -> MetaExpr
MetaStr LMString
name ]
  SDoc -> LlvmM ()
renderLlvm (SDoc -> LlvmM ()) -> SDoc -> LlvmM ()
forall a b. (a -> b) -> a -> b
$ [MetaDecl] -> SDoc
ppLlvmMetas [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 x :: 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 :: Maybe LMString
sectName  = LMString -> Maybe LMString
forall a. a -> Maybe a
Just (LMString -> Maybe LMString) -> LMString -> Maybe LMString
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit "llvm.metadata"
      lmUsedVar :: LlvmVar
lmUsedVar = LMString
-> LlvmType
-> LlvmLinkageType
-> Maybe LMString
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar (String -> LMString
fsLit "llvm.used") LlvmType
ty LlvmLinkageType
Appending Maybe LMString
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)
  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
$ LlvmData -> SDoc
pprLlvmData ([LMGlobal
lmUsed], [])