LlvmCodeGen.hs 4.93 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 Data.Maybe ( fromMaybe )
31 32 33
import System.IO

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


-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
61
-- | Do LLVM code generation on all these Cmms data sections.
62
--
63
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
64
                -> [LlvmUnresData] -> IO ( LlvmEnv )
65

66
cmmDataLlvmGens dflags h env [] lmdata
dterei's avatar
dterei committed
67 68 69 70
  = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
                          resolveLlvmDatas env lmdata []
        lmdoc = {-# SCC "llvm_data_ppr" #-}
                Prt.vcat $ map pprLlvmData lmdata'
71
    in do
72 73 74 75
        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
        Prt.bufLeftRender h lmdoc
        return env'

76
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
dterei's avatar
dterei committed
77 78
  = let lmdata'@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
                                genLlvmData env cmm
79
        env' = funInsert (strCLabel_llvm env l) ty env
80
    in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
81 82 83


-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
84
-- | Do LLVM code generation on all these Cmms procs.
85
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
86
cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
87 88
      -> Int         -- ^ count, used for generating unique subsections
      -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
89 90
      -> IO ()

dterei's avatar
dterei committed
91 92
cmmProcLlvmGens _ _ _ _ [] _ []
  = return ()
93

94
cmmProcLlvmGens _ h _ _ [] _ ivars
95 96 97 98
  = let ivars' = concat ivars
        cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
        ty     = (LMArray (length ivars') i8Ptr)
        usedArray = LMStaticArray (map cast ivars') ty
99
        lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
100
                  (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
dterei's avatar
dterei committed
101 102
    in Prt.bufLeftRender h $ {-# SCC "llvm_data_ppr" #-}
                             pprLlvmData ([lmUsed], [])
dterei's avatar
dterei committed
103

104 105
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars
106

107 108 109 110 111
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
112
    let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
dterei's avatar
dterei committed
113
    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
114
    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
115 116


dterei's avatar
dterei committed
117
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
118 119
cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
            -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
120
cmmLlvmGen dflags us env cmm = do
121
    -- rewrite assignments to global regs
dterei's avatar
dterei committed
122 123
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
                    fixStgRegisters cmm
124 125

    dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
126
        (pprCmmGroup (targetPlatform dflags) [fixed_cmm])
127 128

    -- generate llvm code from cmm
dterei's avatar
dterei committed
129 130
    let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
                                  initUs us $ genLlvmProc env fixed_cmm
131 132

    dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
133
        (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
134 135 136

    return (usGen, env', llvmBC)