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

3 4 5
-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--
6
module LlvmCodeGen ( LlvmVersion, llvmVersionList, 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 GHC.StgToCmm.CgUtils ( fixStgRegisters )
22
import Cmm
23
import CmmUtils
24 25
import Hoopl.Block
import Hoopl.Collections
26
import PprCmm
27 28 29

import BufWrite
import DynFlags
30
import GHC.Platform ( platformArch, Arch(..) )
31
import ErrUtils
dterei's avatar
dterei committed
32
import FastString
33 34
import Outputable
import UniqSupply
35
import SysTools ( figureLlvmVersion )
Peter Wortmann's avatar
Peter Wortmann committed
36
import qualified Stream
37

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

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

       -- Pass header
       showPass dflags "LLVM CodeGen"
54

Peter Wortmann's avatar
Peter Wortmann committed
55
       -- get llvm version, cache for later use
56
       mb_ver <- figureLlvmVersion dflags
Peter Wortmann's avatar
Peter Wortmann committed
57 58

       -- warn if unsupported
59 60 61 62 63 64 65 66 67
       forM_ mb_ver $ \ver -> do
         debugTraceMsg dflags 2
              (text "Using LLVM version:" <+> text (llvmVersionStr ver))
         let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
         when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $
           "You are using an unsupported version of LLVM!" $$
           "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>
           "System LLVM version: " <> text (llvmVersionStr ver) $$
           "We will try though..."
68 69 70 71 72
         let isS390X = platformArch (targetPlatform dflags) == ArchS390X
         let major_ver = head . llvmVersionList $ ver
         when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $
           "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
           "You are using LLVM version: " <> text (llvmVersionStr ver)
Peter Wortmann's avatar
Peter Wortmann committed
73 74

       -- run code generation
75
       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $
Peter Wortmann's avatar
Peter Wortmann committed
76 77 78 79
         llvmCodeGen' (liftStream cmm_stream)

       bFlush bufh

80 81 82
       return a

llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a
Peter Wortmann's avatar
Peter Wortmann committed
83 84
llvmCodeGen' cmm_stream
  = do  -- Preamble
Moritz Angermann's avatar
Moritz Angermann committed
85
        renderLlvm header
Peter Wortmann's avatar
Peter Wortmann committed
86 87 88 89
        ghcInternalFunctions
        cmmMetaLlvmPrelude

        -- Procedures
90
        a <- Stream.consume cmm_stream llvmGroupLlvmGens
Peter Wortmann's avatar
Peter Wortmann committed
91 92

        -- Declare aliases for forward references
93
        renderLlvm . pprLlvmData =<< generateExternDecls
Peter Wortmann's avatar
Peter Wortmann committed
94 95 96

        -- Postamble
        cmmUsedLlvmGens
97 98

        return a
Moritz Angermann's avatar
Moritz Angermann committed
99 100 101
  where
    header :: SDoc
    header = sdocWithDynFlags $ \dflags ->
102
      let target = platformMisc_llvmTarget $ platformMisc dflags
103
      in     text ("target datalayout = \"" ++ getDataLayout dflags target ++ "\"")
Moritz Angermann's avatar
Moritz Angermann committed
104
         $+$ text ("target triple = \"" ++ target ++ "\"")
Peter Wortmann's avatar
Peter Wortmann committed
105

106 107 108 109 110 111 112 113 114
    getDataLayout :: DynFlags -> String -> String
    getDataLayout dflags target =
      case lookup target (llvmTargets $ llvmConfig dflags) of
        Just (LlvmTarget {lDataLayout=dl}) -> dl
        Nothing -> pprPanic "Failed to lookup LLVM data layout" $
                   text "Target:" <+> text target $$
                   hang (text "Available targets:") 4
                        (vcat $ map (text . fst) $ llvmTargets $ llvmConfig dflags)

Peter Wortmann's avatar
Peter Wortmann committed
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
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
134 135

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
136
-- | Do LLVM code generation on all these Cmms data sections.
137
--
Peter Wortmann's avatar
Peter Wortmann committed
138
cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
139

Peter Wortmann's avatar
Peter Wortmann committed
140 141
cmmDataLlvmGens statics
  = do lmdatas <- mapM genLlvmData statics
142

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

Peter Wortmann's avatar
Peter Wortmann committed
145 146
       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
                        = funInsert l ty
Gabor Greif's avatar
Gabor Greif committed
147 148 149
           regGlobal _  = pure ()
       mapM_ regGlobal gs
       gss' <- mapM aliasify $ gs
Peter Wortmann's avatar
Peter Wortmann committed
150

151
       renderLlvm $ pprLlvmData (concat gss', concat tss)
152

153 154 155
-- | 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
156
-- to itself. See: #11649
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
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
182
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Peter Wortmann's avatar
Peter Wortmann committed
183 184 185
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do

186
    -- rewrite assignments to global regs
Peter Wortmann's avatar
Peter Wortmann committed
187
    dflags <- getDynFlag id
188 189
    fixed_cmm <- fixBottom $
                    {-# SCC "llvm_fix_regs" #-}
190
                    fixStgRegisters dflags cmm
191

Peter Wortmann's avatar
Peter Wortmann committed
192
    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
193 194

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

Peter Wortmann's avatar
Peter Wortmann committed
197
    -- pretty print
198
    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
Peter Wortmann's avatar
Peter Wortmann committed
199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217

    -- 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
218 219 220 221 222 223 224
    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
225 226 227 228 229
  renderLlvm $ ppLlvmMetas metas

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

Peter Wortmann's avatar
Peter Wortmann committed
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
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], [])