LlvmCodeGen.hs 7.11 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
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
               -> Stream.Stream IO RawCmmGroup ()
               -> IO ()
llvmCodeGen dflags h us cmm_stream
45
46
  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
       bufh <- newBufHandle h
Peter Wortmann's avatar
Peter Wortmann committed
47
48
49

       -- Pass header
       showPass dflags "LLVM CodeGen"
50

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

       -- warn if unsupported
       debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
58
59
       when (ver /= supportedLlvmVersion && doWarn) $
           putMsg dflags (text "You are using an unsupported version of LLVM!"
60
61
62
                            $+$ text ("Currently only " ++
                                      llvmVersionStr supportedLlvmVersion ++
                                      " is supported.")
Peter Wortmann's avatar
Peter Wortmann committed
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
                            $+$ 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
83
        renderLlvm . pprLlvmData =<< generateExternDecls
Peter Wortmann's avatar
Peter Wortmann committed
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

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

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

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

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

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

124
       renderLlvm $ pprLlvmData (concat gss', concat tss)
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
154
-- | 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
155
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Peter Wortmann's avatar
Peter Wortmann committed
156
157
158
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do

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

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

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

Peter Wortmann's avatar
Peter Wortmann committed
170
    -- pretty print
171
    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
Peter Wortmann's avatar
Peter Wortmann committed
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
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
    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
--
202

Peter Wortmann's avatar
Peter Wortmann committed
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
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], [])