LlvmCodeGen.hs 7.04 KB
Newer Older
1 2
{-# LANGUAGE CPP, TypeFamilies #-}

3 4 5
-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--
6
module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
7 8 9

#include "HsVersions.h"

dterei's avatar
dterei committed
10
import Llvm
11 12 13 14
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
Peter Wortmann's avatar
Peter Wortmann committed
15
import LlvmCodeGen.Regs
16 17
import LlvmMangler

18
import BlockId
19
import CgUtils ( fixStgRegisters )
20
import Cmm
21
import CmmUtils
22 23
import Hoopl
import PprCmm
24 25 26 27

import BufWrite
import DynFlags
import ErrUtils
dterei's avatar
dterei committed
28
import FastString
29 30
import Outputable
import UniqSupply
31
import SysTools ( figureLlvmVersion )
Peter Wortmann's avatar
Peter Wortmann committed
32
import qualified Stream
33

34
import Control.Monad ( when )
Peter Wortmann's avatar
Peter Wortmann committed
35
import Data.Maybe ( fromMaybe, catMaybes )
36 37 38
import System.IO

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
39
-- | Top-level of the LLVM Code generator
40
--
Peter Wortmann's avatar
Peter Wortmann committed
41 42 43 44 45 46 47 48
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
               -> Stream.Stream IO RawCmmGroup ()
               -> IO ()
llvmCodeGen dflags h us cmm_stream
  = do bufh <- newBufHandle h

       -- Pass header
       showPass dflags "LLVM CodeGen"
49

Peter Wortmann's avatar
Peter Wortmann committed
50
       -- get llvm version, cache for later use
51
       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
Peter Wortmann's avatar
Peter Wortmann committed
52 53 54 55 56

       -- warn if unsupported
       debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
57 58
       when (ver /= supportedLlvmVersion && doWarn) $
           putMsg dflags (text "You are using an unsupported version of LLVM!"
59 60 61
                            $+$ text ("Currently only " ++
                                      llvmVersionStr supportedLlvmVersion ++
                                      " is supported.")
Peter Wortmann's avatar
Peter Wortmann committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
                            $+$ text "We will try though...")

       -- run code generation
       runLlvm dflags ver bufh us $
         llvmCodeGen' (liftStream cmm_stream)

       bFlush bufh

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

        -- Procedures
        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
        _ <- Stream.collect llvmStream

        -- Declare aliases for forward references
82
        renderLlvm . pprLlvmData =<< generateExternDecls
Peter Wortmann's avatar
Peter Wortmann committed
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105

        -- Postamble
        cmmUsedLlvmGens

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

        -- Insert functions into map, collect data
        let split (CmmData s d' )     = return $ Just (s, d')
            split (CmmProc h l live g) = do
              -- Set function type
              let l' = case mapLookup (g_entry g) h of
                         Nothing                   -> l
                         Just (Statics info_lbl _) -> info_lbl
              lml <- strCLabel_llvm l'
              funInsert lml =<< llvmFunTy live
              return Nothing
        cdata <- fmap catMaybes $ mapM split cmm

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

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
108
-- | Do LLVM code generation on all these Cmms data sections.
109
--
Peter Wortmann's avatar
Peter Wortmann committed
110
cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
111

Peter Wortmann's avatar
Peter Wortmann committed
112 113
cmmDataLlvmGens statics
  = do lmdatas <- mapM genLlvmData statics
114

Peter Wortmann's avatar
Peter Wortmann committed
115
       let (gss, tss) = unzip lmdatas
116

Peter Wortmann's avatar
Peter Wortmann committed
117 118 119 120
       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
                        = funInsert l ty
           regGlobal _  = return ()
       mapM_ regGlobal (concat gss)
121
       gss' <- mapM aliasify $ concat gss
Peter Wortmann's avatar
Peter Wortmann committed
122

123
       renderLlvm $ pprLlvmData (concat gss', concat tss)
124

125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
-- | 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 cp@(CmmProc hdr entry_lbl live g) =
    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
  where
    blk_map = toBlockMap g

    fix_block :: CmmBlock -> LlvmM RawCmmDecl
    fix_block blk
        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
        , isEmptyBlock middle
        , e_lbl == b_lbl = do
            new_lbl <- mkBlockId <$> getUniqueM

            let fst_blk =
                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
                snd_blk =
                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)

            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]

    fix_block _ = pure cp

fixBottom rcd = pure rcd

dterei's avatar
dterei committed
154
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Peter Wortmann's avatar
Peter Wortmann committed
155 156 157
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do

158
    -- rewrite assignments to global regs
Peter Wortmann's avatar
Peter Wortmann committed
159
    dflags <- getDynFlag id
160 161
    fixed_cmm <- fixBottom $
                    {-# SCC "llvm_fix_regs" #-}
162
                    fixStgRegisters dflags cmm
163

Peter Wortmann's avatar
Peter Wortmann committed
164
    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
165 166

    -- generate llvm code from cmm
Peter Wortmann's avatar
Peter Wortmann committed
167
    llvmBC <- withClearVars $ genLlvmProc fixed_cmm
168

Peter Wortmann's avatar
Peter Wortmann committed
169
    -- pretty print
170
    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
Peter Wortmann's avatar
Peter Wortmann committed
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200

    -- Output, note down used variables
    renderLlvm (vcat docs)
    mapM_ markUsedVar $ concat ivars

cmmLlvmGen _ = return ()

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

cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
    -- Generate / lookup meta data IDs
    tbaaId <- getMetaUniqueId
    setUniqMeta uniq tbaaId
    parentId <- maybe (return Nothing) getUniqMeta parent
    -- Build definition
    return $ MetaUnamed tbaaId $ MetaStruct
        [ MetaStr name
        , case parentId of
          Just p  -> MetaNode p
          Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr
        ]
  renderLlvm $ ppLlvmMetas metas

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

Peter Wortmann's avatar
Peter Wortmann committed
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
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 <- getUsedVars
  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
      ty     = (LMArray (length ivars) i8Ptr)
      usedArray = LMStaticArray (map cast ivars) ty
      sectName  = Just $ fsLit "llvm.metadata"
      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
  if null ivars
     then return ()
     else renderLlvm $ pprLlvmData ([lmUsed], [])