LlvmCodeGen.hs 7.77 KB
Newer Older
Gabor Greif's avatar
Gabor Greif committed
1
{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}
2

3 4 5
-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--
Erik de Castro Lopo's avatar
Erik de Castro Lopo committed
6
module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where
7 8 9

#include "HsVersions.h"

10 11
import GhcPrelude

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

20
import BlockId
21
import CgUtils ( fixStgRegisters )
22
import Cmm
23
import CmmUtils
24 25
import Hoopl.Block
import Hoopl.Collections
26
import PprCmm
27 28 29 30

import BufWrite
import DynFlags
import ErrUtils
dterei's avatar
dterei committed
31
import FastString
32 33
import Outputable
import UniqSupply
34
import SysTools ( figureLlvmVersion )
Peter Wortmann's avatar
Peter Wortmann committed
35
import qualified Stream
36

37
import Control.Monad ( when )
Peter Wortmann's avatar
Peter Wortmann committed
38
import Data.Maybe ( fromMaybe, catMaybes )
39 40 41
import System.IO

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
42
-- | Top-level of the LLVM Code generator
43
--
Peter Wortmann's avatar
Peter Wortmann committed
44 45 46 47
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
               -> Stream.Stream IO RawCmmGroup ()
               -> IO ()
llvmCodeGen dflags h us cmm_stream
48 49
  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
       bufh <- newBufHandle h
Peter Wortmann's avatar
Peter Wortmann committed
50 51 52

       -- Pass header
       showPass dflags "LLVM CodeGen"
53

Peter Wortmann's avatar
Peter Wortmann committed
54
       -- get llvm version, cache for later use
55
       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
Peter Wortmann's avatar
Peter Wortmann committed
56 57 58 59 60

       -- warn if unsupported
       debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
61 62
       when (ver /= supportedLlvmVersion && doWarn) $
           putMsg dflags (text "You are using an unsupported version of LLVM!"
63 64 65
                            $+$ text ("Currently only " ++
                                      llvmVersionStr supportedLlvmVersion ++
                                      " is supported.")
Peter Wortmann's avatar
Peter Wortmann committed
66 67 68 69 70 71 72 73 74 75 76
                            $+$ 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
Moritz Angermann's avatar
Moritz Angermann committed
77
        renderLlvm header
Peter Wortmann's avatar
Peter Wortmann committed
78 79 80 81
        ghcInternalFunctions
        cmmMetaLlvmPrelude

        -- Procedures
82
        () <- Stream.consume cmm_stream llvmGroupLlvmGens
Peter Wortmann's avatar
Peter Wortmann committed
83 84

        -- Declare aliases for forward references
85
        renderLlvm . pprLlvmData =<< generateExternDecls
Peter Wortmann's avatar
Peter Wortmann committed
86 87 88

        -- Postamble
        cmmUsedLlvmGens
Moritz Angermann's avatar
Moritz Angermann committed
89 90 91
  where
    header :: SDoc
    header = sdocWithDynFlags $ \dflags ->
92
      let target = platformMisc_llvmTarget $ platformMisc dflags
Moritz Angermann's avatar
Moritz Angermann committed
93 94 95 96 97
          layout = case lookup target (llvmTargets dflags) of
            Just (LlvmTarget dl _ _) -> dl
            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
      in     text ("target datalayout = \"" ++ layout ++ "\"")
         $+$ text ("target triple = \"" ++ target ++ "\"")
Peter Wortmann's avatar
Peter Wortmann committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117

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
118 119

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
120
-- | Do LLVM code generation on all these Cmms data sections.
121
--
Peter Wortmann's avatar
Peter Wortmann committed
122
cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
123

Peter Wortmann's avatar
Peter Wortmann committed
124 125
cmmDataLlvmGens statics
  = do lmdatas <- mapM genLlvmData statics
126

Gabor Greif's avatar
Gabor Greif committed
127
       let (concat -> gs, tss) = unzip lmdatas
128

Peter Wortmann's avatar
Peter Wortmann committed
129 130
       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
                        = funInsert l ty
Gabor Greif's avatar
Gabor Greif committed
131 132 133
           regGlobal _  = pure ()
       mapM_ regGlobal gs
       gss' <- mapM aliasify $ gs
Peter Wortmann's avatar
Peter Wortmann committed
134

135
       renderLlvm $ pprLlvmData (concat gss', concat tss)
136

137 138 139
-- | 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
140
-- to itself. See: #11649
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
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
166
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Peter Wortmann's avatar
Peter Wortmann committed
167 168 169
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do

170
    -- rewrite assignments to global regs
Peter Wortmann's avatar
Peter Wortmann committed
171
    dflags <- getDynFlag id
172 173
    fixed_cmm <- fixBottom $
                    {-# SCC "llvm_fix_regs" #-}
174
                    fixStgRegisters dflags cmm
175

Peter Wortmann's avatar
Peter Wortmann committed
176
    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
177 178

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

Peter Wortmann's avatar
Peter Wortmann committed
181
    -- pretty print
182
    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
Peter Wortmann's avatar
Peter Wortmann committed
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201

    -- 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
202 203 204 205 206 207 208
    return $ MetaUnnamed tbaaId $ MetaStruct $
          case parentId of
              Just p  -> [ MetaStr name, MetaNode 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 -> [ MetaStr name ]
Peter Wortmann's avatar
Peter Wortmann committed
209 210 211 212 213
  renderLlvm $ ppLlvmMetas metas

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

Peter Wortmann's avatar
Peter Wortmann committed
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
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], [])