More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[ghc.git] / compiler / llvmGen / LlvmCodeGen.hs
1 -- -----------------------------------------------------------------------------
2 -- | This is the top-level module in the LLVM code generator.
3 --
4
5 module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
6
7 #include "HsVersions.h"
8
9 import Llvm
10 import LlvmCodeGen.Base
11 import LlvmCodeGen.CodeGen
12 import LlvmCodeGen.Data
13 import LlvmCodeGen.Ppr
14 import LlvmMangler
15
16 import CgUtils ( fixStgRegisters )
17 import OldCmm
18 import OldPprCmm
19
20 import BufWrite
21 import DynFlags
22 import ErrUtils
23 import FastString
24 import Outputable
25 import qualified Pretty as Prt
26 import UniqSupply
27 import Util
28 import SysTools ( figureLlvmVersion )
29
30 import Data.Maybe ( fromMaybe )
31 import System.IO
32
33 -- -----------------------------------------------------------------------------
34 -- | Top-level of the LLVM Code generator
35 --
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 split (CmmData s d' ) (d,e) = ((s,d'):d,e)
41 split (CmmProc i l _) (d,e) =
42 let lbl = strCLabel_llvm env $ case i of
43 Nothing -> l
44 Just (Statics info_lbl _) -> info_lbl
45 env' = funInsert lbl llvmFunTy e
46 in (d,env')
47 in do
48 bufh <- newBufHandle h
49 Prt.bufLeftRender bufh $ pprLlvmHeader
50 ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
51 env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
52 cmmProcLlvmGens dflags bufh us env' cmm 1 []
53 bFlush bufh
54 return ()
55
56
57 -- -----------------------------------------------------------------------------
58 -- | Do LLVM code generation on all these Cmms data sections.
59 --
60 cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
61 -> [LlvmUnresData] -> IO ( LlvmEnv )
62
63 cmmDataLlvmGens dflags h env [] lmdata
64 = let (env', lmdata') = resolveLlvmDatas env lmdata []
65 lmdoc = Prt.vcat $ map pprLlvmData lmdata'
66 in do
67 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
68 Prt.bufLeftRender h lmdoc
69 return env'
70
71 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
72 = let lmdata'@(l, _, ty, _) = genLlvmData env cmm
73 env' = funInsert (strCLabel_llvm env l) ty env
74 in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
75
76
77 -- -----------------------------------------------------------------------------
78 -- | Do LLVM code generation on all these Cmms procs.
79 --
80 cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
81 -> Int -- ^ count, used for generating unique subsections
82 -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
83 -> IO ()
84
85 cmmProcLlvmGens _ _ _ _ [] _ []
86 = return ()
87
88 cmmProcLlvmGens _ h _ _ [] _ ivars
89 = let ivars' = concat ivars
90 cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
91 ty = (LMArray (length ivars') i8Ptr)
92 usedArray = LMStaticArray (map cast ivars') ty
93 lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
94 (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
95 in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
96
97 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
98 = cmmProcLlvmGens dflags h us env cmms count ivars
99
100 cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars
101 = cmmProcLlvmGens dflags h us env cmms count ivars
102
103 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
104 (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
105 let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
106 Prt.bufLeftRender h $ Prt.vcat docs
107 cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
108
109
110 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
111 cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
112 -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
113 cmmLlvmGen dflags us env cmm = do
114 -- rewrite assignments to global regs
115 let fixed_cmm = fixStgRegisters cmm
116
117 dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
118 (pprCmmGroup (targetPlatform dflags) [fixed_cmm])
119
120 -- generate llvm code from cmm
121 let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
122
123 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
124 (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
125
126 return (usGen, env', llvmBC)
127