LlvmCodeGen.hs 6.26 KB
Newer Older
1 2 3 4
-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--

5
module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
6 7 8

#include "HsVersions.h"

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

17
import CgUtils ( fixStgRegisters )
18 19 20
import Cmm
import Hoopl
import PprCmm
21 22 23 24

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

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

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
38
-- | Top-level of the LLVM Code generator
39
--
Peter Wortmann's avatar
Peter Wortmann committed
40 41 42 43 44 45 46 47
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"
48

Peter Wortmann's avatar
Peter Wortmann committed
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
       -- get llvm version, cache for later use
       ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
       writeIORef (llvmVersion dflags) ver

       -- warn if unsupported
       debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
       when (ver < minSupportLlvmVersion && doWarn) $
           errorMsg dflags (text "You are using an old version of LLVM that"
                            <> text " isn't supported anymore!"
                            $+$ text "We will try though...")
       when (ver > maxSupportLlvmVersion && doWarn) $
           putMsg dflags (text "You are using a new version of LLVM that"
                          <> text " hasn't been tested yet!"
                          $+$ 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
        renderLlvm . pprLlvmData =<< generateAliases

        -- 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
108 109

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

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

Peter Wortmann's avatar
Peter Wortmann committed
117
       let (gss, tss) = unzip lmdatas
118

Peter Wortmann's avatar
Peter Wortmann committed
119 120 121 122 123 124
       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
                        = funInsert l ty
           regGlobal _  = return ()
       mapM_ regGlobal (concat gss)

       renderLlvm $ pprLlvmData (concat gss, concat tss)
125

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

130
    -- rewrite assignments to global regs
Peter Wortmann's avatar
Peter Wortmann committed
131
    dflags <- getDynFlag id
dterei's avatar
dterei committed
132
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
133
                    fixStgRegisters dflags cmm
134

Peter Wortmann's avatar
Peter Wortmann committed
135
    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
136
        (pprCmmGroup [fixed_cmm])
137 138

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

Peter Wortmann's avatar
Peter Wortmann committed
141 142 143 144
    -- allocate IDs for info table and code, so the mangler can later
    -- make sure they end up next to each other.
    itableSection <- freshSectionId
    _codeSection <- freshSectionId
145

Peter Wortmann's avatar
Peter Wortmann committed
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
    -- pretty print
    (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC

    -- 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
--
178

Peter Wortmann's avatar
Peter Wortmann committed
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
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], [])