compiler/llvmGen/LlvmCodeGen.hs

   1 {-# LANGUAGE CPP, TypeFamilies #-}
   2
   3 -- -----------------------------------------------------------------------------
   4 -- | This is the top-level module in the LLVM code generator.
   5 --
   6 module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
   7
   8 #include "HsVersions.h"
   9
  10 import Llvm
  11 import LlvmCodeGen.Base
  12 import LlvmCodeGen.CodeGen
  13 import LlvmCodeGen.Data
  14 import LlvmCodeGen.Ppr
  15 import LlvmCodeGen.Regs
  16 import LlvmMangler
  17
  18 import BlockId
  19 import CgUtils ( fixStgRegisters )
  20 import Cmm
  21 import CmmUtils
  22 import Hoopl
  23 import PprCmm
  24
  25 import BufWrite
  26 import DynFlags
  27 import ErrUtils
  28 import FastString
  29 import Outputable
  30 import UniqSupply
  31 import SysTools ( figureLlvmVersion )
  32 import qualified Stream
  33
  34 import Control.Monad ( when )
  35 import Data.Maybe ( fromMaybe, catMaybes )
  36 import System.IO
  37
  38 -- -----------------------------------------------------------------------------
  39 -- | Top-level of the LLVM Code generator
  40 --
  41 llvmCodeGen :: DynFlags -> Handle -> UniqSupply
  42                -> Stream.Stream IO RawCmmGroup ()
  43                -> IO ()
  44 llvmCodeGen dflags h us cmm_stream
  45   = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
  46        bufh <- newBufHandle h
  47
  48        -- Pass header
  49        showPass dflags "LLVM CodeGen"
  50
  51        -- get llvm version, cache for later use
  52        ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
  53
  54        -- warn if unsupported
  55        debugTraceMsg dflags 2
  56             (text "Using LLVM version:" <+> text (show ver))
  57        let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
  58        when (ver /= supportedLlvmVersion && doWarn) $
  59            putMsg dflags (text "You are using an unsupported version of LLVM!"
  60                             $+$ text ("Currently only " ++
  61                                       llvmVersionStr supportedLlvmVersion ++
  62                                       " is supported.")
  63                             $+$ text "We will try though...")
  64
  65        -- run code generation
  66        runLlvm dflags ver bufh us $
  67          llvmCodeGen' (liftStream cmm_stream)
  68
  69        bFlush bufh
  70
  71 llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
  72 llvmCodeGen' cmm_stream
  73   = do  -- Preamble
  74         renderLlvm pprLlvmHeader
  75         ghcInternalFunctions
  76         cmmMetaLlvmPrelude
  77
  78         -- Procedures
  79         let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
  80         _ <- Stream.collect llvmStream
  81
  82         -- Declare aliases for forward references
  83         renderLlvm . pprLlvmData =<< generateExternDecls
  84
  85         -- Postamble
  86         cmmUsedLlvmGens
  87
  88 llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
  89 llvmGroupLlvmGens cmm = do
  90
  91         -- Insert functions into map, collect data
  92         let split (CmmData s d' )     = return $ Just (s, d')
  93             split (CmmProc h l live g) = do
  94               -- Set function type
  95               let l' = case mapLookup (g_entry g) h of
  96                          Nothing                   -> l
  97                          Just (Statics info_lbl _) -> info_lbl
  98               lml <- strCLabel_llvm l'
  99               funInsert lml =<< llvmFunTy live
 100               return Nothing
 101         cdata <- fmap catMaybes $ mapM split cmm
 102
 103         {-# SCC "llvm_datas_gen" #-}
 104           cmmDataLlvmGens cdata
 105         {-# SCC "llvm_procs_gen" #-}
 106           mapM_ cmmLlvmGen cmm
 107
 108 -- -----------------------------------------------------------------------------
 109 -- | Do LLVM code generation on all these Cmms data sections.
 110 --
 111 cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
 112
 113 cmmDataLlvmGens statics
 114   = do lmdatas <- mapM genLlvmData statics
 115
 116        let (gss, tss) = unzip lmdatas
 117
 118        let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
 119                         = funInsert l ty
 120            regGlobal _  = return ()
 121        mapM_ regGlobal (concat gss)
 122        gss' <- mapM aliasify $ concat gss
 123
 124        renderLlvm $ pprLlvmData (concat gss', concat tss)
 125
 126 -- | LLVM can't handle entry blocks which loop back to themselves (could be
 127 -- seen as an LLVM bug) so we rearrange the code to keep the original entry
 128 -- label which branches to a newly generated second label that branches back
 129 -- to itself. See: Trac #11649
 130 fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
 131 fixBottom cp@(CmmProc hdr entry_lbl live g) =
 132     maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
 133   where
 134     blk_map = toBlockMap g
 135
 136     fix_block :: CmmBlock -> LlvmM RawCmmDecl
 137     fix_block blk
 138         | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
 139         , isEmptyBlock middle
 140         , e_lbl == b_lbl = do
 141             new_lbl <- mkBlockId <$> getUniqueM
 142
 143             let fst_blk =
 144                     BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
 145                 snd_blk =
 146                     BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
 147
 148             pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
 149                 $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
 150
 151     fix_block _ = pure cp
 152
 153 fixBottom rcd = pure rcd
 154
 155 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
 156 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
 157 cmmLlvmGen cmm@CmmProc{} = do
 158
 159     -- rewrite assignments to global regs
 160     dflags <- getDynFlag id
 161     fixed_cmm <- fixBottom $
 162                     {-# SCC "llvm_fix_regs" #-}
 163                     fixStgRegisters dflags cmm
 164
 165     dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
 166
 167     -- generate llvm code from cmm
 168     llvmBC <- withClearVars $ genLlvmProc fixed_cmm
 169
 170     -- pretty print
 171     (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
 172
 173     -- Output, note down used variables
 174     renderLlvm (vcat docs)
 175     mapM_ markUsedVar $ concat ivars
 176
 177 cmmLlvmGen _ = return ()
 178
 179 -- -----------------------------------------------------------------------------
 180 -- | Generate meta data nodes
 181 --
 182
 183 cmmMetaLlvmPrelude :: LlvmM ()
 184 cmmMetaLlvmPrelude = do
 185   metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
 186     -- Generate / lookup meta data IDs
 187     tbaaId <- getMetaUniqueId
 188     setUniqMeta uniq tbaaId
 189     parentId <- maybe (return Nothing) getUniqMeta parent
 190     -- Build definition
 191     return $ MetaUnnamed tbaaId $ MetaStruct
 192         [ MetaStr name
 193         , case parentId of
 194           Just p  -> MetaNode p
 195           Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr
 196         ]
 197   renderLlvm $ ppLlvmMetas metas
 198
 199 -- -----------------------------------------------------------------------------
 200 -- | Marks variables as used where necessary
 201 --
 202
 203 cmmUsedLlvmGens :: LlvmM ()
 204 cmmUsedLlvmGens = do
 205
 206   -- LLVM would discard variables that are internal and not obviously
 207   -- used if we didn't provide these hints. This will generate a
 208   -- definition of the form
 209   --
 210   --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
 211   --
 212   -- Which is the LLVM way of protecting them against getting removed.
 213   ivars <- getUsedVars
 214   let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
 215       ty     = (LMArray (length ivars) i8Ptr)
 216       usedArray = LMStaticArray (map cast ivars) ty
 217       sectName  = Just $ fsLit "llvm.metadata"
 218       lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
 219       lmUsed    = LMGlobal lmUsedVar (Just usedArray)
 220   if null ivars
 221      then return ()
 222      else renderLlvm $ pprLlvmData ([lmUsed], [])