LlvmCodeGen.hs 6.21 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
14
15
import LlvmMangler

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

import BufWrite
import DynFlags
import ErrUtils
dterei's avatar
dterei committed
24
import FastString
25
26
27
import Outputable
import qualified Pretty as Prt
import UniqSupply
dterei's avatar
dterei committed
28
import Util
29
import SysTools ( figureLlvmVersion )
30

31
import Control.Monad ( when )
32
import Data.IORef ( writeIORef )
33
import Data.Maybe ( fromMaybe )
34
35
36
import System.IO

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
37
-- | Top-level of the LLVM Code generator
38
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
39
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
40
llvmCodeGen dflags h us cmms
41
  = let cmm = concat cmms
42
        (cdata,env) = {-# SCC "llvm_split" #-}
43
                      foldr split ([], initLlvmEnv dflags) cmm
44
        split (CmmData s d' ) (d,e) = ((s,d'):d,e)
Simon Marlow's avatar
Simon Marlow committed
45
        split (CmmProc h l live g) (d,e) =
46
47
48
49
            let lbl = strCLabel_llvm env $
                        case mapLookup (g_entry g) h of
                          Nothing                   -> l
                          Just (Statics info_lbl _) -> info_lbl
50
                env' = funInsert lbl (llvmFunTy dflags live) e
51
            in (d,env')
52
    in do
53
        showPass dflags "LlVM CodeGen"
Ian Lynagh's avatar
Ian Lynagh committed
54
        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
55
        bufh <- newBufHandle h
Ian Lynagh's avatar
Ian Lynagh committed
56
        Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
57
        ver  <- getLlvmVersion
dterei's avatar
dterei committed
58
59
        env' <- {-# SCC "llvm_datas_gen" #-}
                cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
60
        {-# SCC "llvm_procs_gen" #-}
dterei's avatar
dterei committed
61
             cmmProcLlvmGens dflags bufh us env' cmm 1 []
62
63
        bFlush bufh
        return  ()
64

65
66
67
68
69
70
  where
    -- | Handle setting up the LLVM version.
    getLlvmVersion = do
        ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
        -- cache llvm version for later use
        writeIORef (llvmVersion dflags) ver
dterei's avatar
dterei committed
71
72
        debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
73
74
        let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
        when (ver < minSupportLlvmVersion && doWarn) $
75
            errorMsg dflags (text "You are using an old version of LLVM that"
dterei's avatar
dterei committed
76
                             <> text " isn't supported anymore!"
77
                             $+$ text "We will try though...")
78
        when (ver > maxSupportLlvmVersion && doWarn) $
79
            putMsg dflags (text "You are using a new version of LLVM that"
dterei's avatar
dterei committed
80
                           <> text " hasn't been tested yet!"
81
82
83
                           $+$ text "We will try though...")
        return ver

84
85

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
86
-- | Do LLVM code generation on all these Cmms data sections.
87
--
88
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
89
                -> [LlvmUnresData] -> IO ( LlvmEnv )
90

91
cmmDataLlvmGens dflags h env [] lmdata
dterei's avatar
dterei committed
92
  = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
93
                          resolveLlvmDatas env lmdata
dterei's avatar
dterei committed
94
        lmdoc = {-# SCC "llvm_data_ppr" #-}
Ian Lynagh's avatar
Ian Lynagh committed
95
                vcat $ map pprLlvmData lmdata'
96
    in do
Ian Lynagh's avatar
Ian Lynagh committed
97
        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
98
        {-# SCC "llvm_data_out" #-}
Ian Lynagh's avatar
Ian Lynagh committed
99
            Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
100
101
        return env'

102
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
103
104
105
106
107
108
109
  = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
                           genLlvmData env cmm
        env' = {-# SCC "llvm_data_insert" #-}
               funInsert (strCLabel_llvm env l) ty env
        lmdata' = {-# SCC "llvm_data_append" #-}
                  lm:lmdata
    in cmmDataLlvmGens dflags h env' cmms lmdata'
110
111
112


-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
113
-- | Do LLVM code generation on all these Cmms procs.
114
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
115
cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
116
117
      -> Int         -- ^ count, used for generating unique subsections
      -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
118
119
      -> IO ()

Ian Lynagh's avatar
Ian Lynagh committed
120
cmmProcLlvmGens dflags h _ _ [] _ ivars
121
122
123
124
125
126
127
128
129
130
131
132
    | null ivars' = return ()
    | otherwise   = Prt.bufLeftRender h $
                        {-# SCC "llvm_used_ppr" #-}
                        withPprStyleDoc dflags (mkCodeStyle CStyle) $
                        pprLlvmData ([lmUsed], [])
  where
    ivars' = concat ivars
    cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
    ty     = (LMArray (length ivars') i8Ptr)
    usedArray = LMStaticArray (map cast ivars') ty
    lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
              (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
dterei's avatar
dterei committed
133

134
135
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars
136

137
138
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
Simon Peyton Jones's avatar
Simon Peyton Jones committed
139
    let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
Ian Lynagh's avatar
Ian Lynagh committed
140
    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
Ian Lynagh's avatar
Ian Lynagh committed
141
                          withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
142
    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
143
144


dterei's avatar
dterei committed
145
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
146
147
cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
            -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
148
cmmLlvmGen dflags us env cmm = do
149
    -- rewrite assignments to global regs
dterei's avatar
dterei committed
150
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
151
                    fixStgRegisters dflags cmm
152
153

    dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
154
        (pprCmmGroup [fixed_cmm])
155
156

    -- generate llvm code from cmm
dterei's avatar
dterei committed
157
158
    let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
                                  initUs us $ genLlvmProc env fixed_cmm
159
160

    dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
Ian Lynagh's avatar
Ian Lynagh committed
161
        (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
162
163
164

    return (usGen, env', llvmBC)