Move activeStgRegs into CodeGen.Platform
[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 Control.Monad ( when )
31 import Data.IORef ( writeIORef )
32 import Data.Maybe ( fromMaybe )
33 import System.IO
34
35 -- -----------------------------------------------------------------------------
36 -- | Top-level of the LLVM Code generator
37 --
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 split p@(CmmProc _ l _) (d,e) =
45 let lbl = strCLabel_llvm env $ case topInfoTable p of
46 Nothing -> l
47 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"
52 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
53 bufh <- newBufHandle h
54 Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
55 ver <- getLlvmVersion
56 env' <- {-# SCC "llvm_datas_gen" #-}
57 cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
58 {-# SCC "llvm_procs_gen" #-}
59 cmmProcLlvmGens dflags bufh us env' cmm 1 []
60 bFlush bufh
61 return ()
62
63 where
64 -- | Handle setting up the LLVM version.
65 getLlvmVersion = do
66 ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
67 -- cache llvm version for later use
68 writeIORef (llvmVersion dflags) ver
69 when (ver < minSupportLlvmVersion) $
70 errorMsg dflags (text "You are using an old version of LLVM that"
71 <> text " isn't supported anymore!"
72 $+$ text "We will try though...")
73 when (ver > maxSupportLlvmVersion) $
74 putMsg dflags (text "You are using a new version of LLVM that"
75 <> text " hasn't been tested yet!"
76 $+$ text "We will try though...")
77 return ver
78
79
80 -- -----------------------------------------------------------------------------
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
87 = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
88 resolveLlvmDatas env lmdata
89 lmdoc = {-# SCC "llvm_data_ppr" #-}
90 vcat $ map pprLlvmData lmdata'
91 in do
92 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
93 {-# SCC "llvm_data_out" #-}
94 Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
95 return env'
96
97 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
98 = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
99 genLlvmData env cmm
100 env' = {-# SCC "llvm_data_insert" #-}
101 funInsert (strCLabel_llvm env l) ty env
102 lmdata' = {-# SCC "llvm_data_append" #-}
103 lm:lmdata
104 in cmmDataLlvmGens dflags h env' cmms lmdata'
105
106
107 -- -----------------------------------------------------------------------------
108 -- | Do LLVM code generation on all these Cmms procs.
109 --
110 cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
111 -> Int -- ^ count, used for generating unique subsections
112 -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
113 -> IO ()
114
115 cmmProcLlvmGens _ _ _ _ [] _ []
116 = return ()
117
118 cmmProcLlvmGens dflags h _ _ [] _ ivars
119 = let ivars' = concat ivars
120 cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
121 ty = (LMArray (length ivars') i8Ptr)
122 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" #-}
126 withPprStyleDoc dflags (mkCodeStyle CStyle) $
127 pprLlvmData ([lmUsed], [])
128
129 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
130 = cmmProcLlvmGens dflags h us env cmms count ivars
131
132 cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars
133 = cmmProcLlvmGens dflags h us env cmms count ivars
134
135 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
136 (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
137 let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
138 Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
139 withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
140 cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
141
142
143 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
144 cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
145 -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
146 cmmLlvmGen dflags us env cmm = do
147 -- rewrite assignments to global regs
148 let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
149 fixStgRegisters (targetPlatform dflags) cmm
150
151 dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
152 (pprCmmGroup [fixed_cmm])
153
154 -- generate llvm code from cmm
155 let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
156 initUs us $ genLlvmProc env fixed_cmm
157
158 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
159 (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
160
161 return (usGen, env', llvmBC)
162