-- | This is the top-level module in the LLVM code generator.
--
-module LlvmCodeGen ( llvmCodeGen ) where
+module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
#include "HsVersions.h"
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
+import LlvmMangler
+
import CLabel
-import Cmm
import CgUtils ( fixStgRegisters )
-import PprCmm
+import OldCmm
+import OldPprCmm
import BufWrite
import DynFlags
import qualified Pretty as Prt
import UniqSupply
import Util
+import SysTools ( figureLlvmVersion )
+import Data.Maybe ( fromMaybe )
import System.IO
-- -----------------------------------------------------------------------------
--- | Top-level of the llvm codegen
+-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
llvmCodeGen dflags h us cmms
- = do
- let cmm = concat $ map (\(Cmm top) -> top) cmms
-
- bufh <- newBufHandle h
-
- Prt.bufLeftRender bufh $ pprLlvmHeader
-
- env <- cmmDataLlvmGens dflags bufh cmm
- cmmProcLlvmGens dflags bufh us env cmm 1 []
-
- bFlush bufh
-
- return ()
+ = let cmm = concat $ map (\(Cmm top) -> top) cmms
+ (cdata,env) = foldr split ([],initLlvmEnv) cmm
+ split (CmmData s d' ) (d,e) = ((s,d'):d,e)
+ split (CmmProc i l _) (d,e) =
+ let lbl = strCLabel_llvm $ if not (null i)
+ then entryLblToInfoLbl l
+ else l
+ env' = funInsert lbl llvmFunTy e
+ in (d,env')
+ in do
+ bufh <- newBufHandle h
+ Prt.bufLeftRender bufh $ pprLlvmHeader
+ ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+
+ env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
+ cmmProcLlvmGens dflags bufh us env' cmm 1 []
+
+ bFlush bufh
+ return ()
-- -----------------------------------------------------------------------------
--- | Do llvm code generation on all these cmms data sections.
+-- | Do LLVM code generation on all these Cmms data sections.
--
-cmmDataLlvmGens
- :: DynFlags
- -> BufHandle
- -> [RawCmmTop]
- -> IO ( LlvmEnv )
-
-cmmDataLlvmGens _ _ []
- = return ( initLlvmEnv )
-
-cmmDataLlvmGens dflags h cmm =
- let exData (CmmData s d) = [(s,d)]
- exData _ = []
-
- exProclbl (CmmProc i l _ _)
- | not (null i) = [strCLabel_llvm $ entryLblToInfoLbl l]
- exProclbl (CmmProc _ l _ _) | otherwise = [strCLabel_llvm l]
- exProclbl _ = []
-
- cproc = concat $ map exProclbl cmm
- cdata = concat $ map exData cmm
- env = foldl (\e l -> funInsert l llvmFunTy e) initLlvmEnv cproc
- in cmmDataLlvmGens' dflags h env cdata []
-
-cmmDataLlvmGens'
- :: DynFlags
- -> BufHandle
- -> LlvmEnv
- -> [(Section, [CmmStatic])]
- -> [LlvmUnresData]
- -> IO ( LlvmEnv )
-
-cmmDataLlvmGens' dflags h env [] lmdata
- = do
- let (env', lmdata') = resolveLlvmDatas dflags env lmdata []
- let lmdoc = Prt.vcat $ map (pprLlvmData dflags) lmdata'
+cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])]
+ -> [LlvmUnresData] -> IO ( LlvmEnv )
+cmmDataLlvmGens dflags h env [] lmdata
+ = let (env', lmdata') = resolveLlvmDatas env lmdata []
+ lmdoc = Prt.vcat $ map pprLlvmData lmdata'
+ in do
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
-
Prt.bufLeftRender h lmdoc
return env'
-cmmDataLlvmGens' dflags h env (cmm:cmms) lmdata
- = do
- let lmdata'@(l, ty, _) = genLlvmData dflags cmm
- let env' = funInsert (strCLabel_llvm l) ty env
- cmmDataLlvmGens' dflags h env' cmms (lmdata ++ [lmdata'])
+cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
+ = let lmdata'@(l, _, ty, _) = genLlvmData cmm
+ env' = funInsert (strCLabel_llvm l) ty env
+ in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
-- -----------------------------------------------------------------------------
--- | Do llvm code generation on all these cmms procs.
+-- | Do LLVM code generation on all these Cmms procs.
--
-cmmProcLlvmGens
- :: DynFlags
- -> BufHandle
- -> UniqSupply
- -> LlvmEnv
- -> [RawCmmTop]
+cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop]
-> Int -- ^ count, used for generating unique subsections
-> [LlvmVar] -- ^ info tables that need to be marked as 'used'
-> IO ()
cmmProcLlvmGens _ _ _ _ [] _ []
= return ()
-cmmProcLlvmGens dflags h _ _ [] _ ivars
- = do
- let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
- let ty = (LMArray (length ivars) i8Ptr)
- let usedArray = LMStaticArray (map cast ivars) ty
- let lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
- (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
- Prt.bufLeftRender h $ pprLlvmData dflags ([lmUsed], [])
+cmmProcLlvmGens _ h _ _ [] _ ivars
+ = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+ ty = (LMArray (length ivars) i8Ptr)
+ usedArray = LMStaticArray (map cast ivars) ty
+ lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
+ (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
+ in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
= do
- (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
+ (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
- let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop dflags env' count) llvm
- Prt.bufLeftRender h $ Prt.vcat docs
+ let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm
+ Prt.bufLeftRender h $ Prt.vcat docs
- cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
+ cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
--- | Complete llvm code generation phase for a single top-level chunk of Cmm.
-cmmLlvmGen
- :: DynFlags
- -> UniqSupply
- -> LlvmEnv
- -> RawCmmTop -- ^ the cmm to generate code for
- -> IO ( UniqSupply,
- LlvmEnv,
- [LlvmCmmTop] ) -- llvm code
-
+-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
+cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
+ -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
cmmLlvmGen dflags us env cmm
= do
-- rewrite assignments to global regs
(pprCmm $ Cmm [fixed_cmm])
-- generate llvm code from cmm
- let ((env', llvmBC), usGen) = initUs us $ genLlvmCode dflags env fixed_cmm
+ let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
- (vcat $ map (docToSDoc . fst . pprLlvmCmmTop dflags env' 0) llvmBC)
+ (vcat $ map (docToSDoc . fst . pprLlvmCmmTop env' 0) llvmBC)
return (usGen, env', llvmBC)
-
--- -----------------------------------------------------------------------------
--- | Instruction selection
---
-genLlvmCode
- :: DynFlags
- -> LlvmEnv
- -> RawCmmTop
- -> UniqSM (LlvmEnv, [LlvmCmmTop])
-
-genLlvmCode _ env (CmmData _ _)
- = return (env, [])
-
-genLlvmCode _ env (CmmProc _ _ _ (ListGraph []))
- = return (env, [])
-
-genLlvmCode _ env cp@(CmmProc _ _ _ _)
- = genLlvmProc env cp
-
projects / ghc-hetmet.git / blobdiff