LlvmCodeGen.hs 6.25 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
    | 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
Peter Wortmann's avatar
Peter Wortmann committed
131 132 133
    lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending
                  (Just $ fsLit "llvm.metadata") Nothing Global
    lmUsed    = LMGlobal lmUsedVar (Just usedArray)
dterei's avatar
dterei committed
134

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

138 139
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
140
    let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
Ian Lynagh's avatar
Ian Lynagh committed
141
    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
Ian Lynagh's avatar
Ian Lynagh committed
142
                          withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
143
    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
144 145


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

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

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

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

    return (usGen, env', llvmBC)