LlvmCodeGen.hs 6.12 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
import OldCmm
import OldPprCmm
19 20 21 22

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

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

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

63 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
        when (ver < minSupportLlvmVersion) $
            errorMsg dflags (text "You are using an old version of LLVM that"
dterei's avatar
dterei committed
71
                             <> text " isn't supported anymore!"
72 73 74
                             $+$ text "We will try though...")
        when (ver > maxSupportLlvmVersion) $
            putMsg dflags (text "You are using a new version of LLVM that"
dterei's avatar
dterei committed
75
                           <> text " hasn't been tested yet!"
76 77 78
                           $+$ text "We will try though...")
        return ver

79 80

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
81
-- | Do LLVM code generation on all these Cmms data sections.
82
--
83
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
84
                -> [LlvmUnresData] -> IO ( LlvmEnv )
85

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

97
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
98 99 100 101 102 103 104
  = 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'
105 106 107


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

dterei's avatar
dterei committed
115 116
cmmProcLlvmGens _ _ _ _ [] _ []
  = return ()
117

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

129 130
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars
131

132 133 134 135 136
cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars

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


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

    dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
152
        (pprCmmGroup [fixed_cmm])
153 154

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

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

    return (usGen, env', llvmBC)