[commit: ghc] master: Add CCS for llvm (90d2acd)
David Terei
davidterei at gmail.com
Sun Dec 4 05:48:47 CET 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/90d2acd1691d3398dc6cbc51ef9b43f037aef1fe
>---------------------------------------------------------------
commit 90d2acd1691d3398dc6cbc51ef9b43f037aef1fe
Author: David Terei <davidterei at gmail.com>
Date: Thu Dec 1 14:20:43 2011 -0800
Add CCS for llvm
>---------------------------------------------------------------
compiler/llvmGen/LlvmCodeGen.hs | 26 +++++++++++++++++---------
compiler/llvmGen/LlvmCodeGen/Base.hs | 27 ++++++++++++++++++---------
compiler/llvmGen/LlvmMangler.hs | 2 +-
3 files changed, 36 insertions(+), 19 deletions(-)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index b29c215..321fac3 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -49,8 +49,10 @@ llvmCodeGen dflags h us cmms
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 []
+ env' <- {-# SCC "llvm_datas_gen" #-}
+ cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
+ _ <- {-# SCC "llvm_procs_gen" #-}
+ cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh
return ()
@@ -62,15 +64,18 @@ cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
-> [LlvmUnresData] -> IO ( LlvmEnv )
cmmDataLlvmGens dflags h env [] lmdata
- = let (env', lmdata') = resolveLlvmDatas env lmdata []
- lmdoc = Prt.vcat $ map pprLlvmData lmdata'
+ = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
+ resolveLlvmDatas env lmdata []
+ lmdoc = {-# SCC "llvm_data_ppr" #-}
+ 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
- = let lmdata'@(l, _, ty, _) = genLlvmData env cmm
+ = let lmdata'@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
+ genLlvmData env cmm
env' = funInsert (strCLabel_llvm env l) ty env
in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
@@ -93,7 +98,8 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
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], [])
+ in Prt.bufLeftRender h $ {-# SCC "llvm_data_ppr" #-}
+ pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars
@@ -104,7 +110,7 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
- Prt.bufLeftRender h $ Prt.vcat docs
+ Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
@@ -113,13 +119,15 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
-> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
cmmLlvmGen dflags us env cmm = do
-- rewrite assignments to global regs
- let fixed_cmm = fixStgRegisters cmm
+ let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
+ fixStgRegisters cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup (targetPlatform dflags) [fixed_cmm])
-- generate llvm code from cmm
- let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
+ let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
+ initUs us $ genLlvmProc env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
(vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index f075aaa..d09cfd9 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -158,17 +158,26 @@ initLlvmEnv platform = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion, platform
-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
-clearVars (LlvmEnv (e1, _, n, p)) = LlvmEnv (e1, emptyUFM, n, p)
+clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
+ LlvmEnv (e1, emptyUFM, n, p)
-- | Insert functions into the environment.
-varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (e1, addToUFM e2 s t, n, p)
-funInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (addToUFM e1 s t, e2, n, p)
+varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
+varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
+ LlvmEnv (e1, addToUFM e2 s t, n, p)
+
+funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
+funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
+ LlvmEnv (addToUFM e1 s t, e2, n, p)
-- | Lookup functions in the environment.
-varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (LlvmEnv (_, e2, _, _)) = lookupUFM e2 s
-funLookup s (LlvmEnv (e1, _, _, _)) = lookupUFM e1 s
+varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
+varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
+ lookupUFM e2 s
+
+funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
+funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
+ lookupUFM e1 s
-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmEnv -> LlvmVersion
@@ -188,8 +197,8 @@ getLlvmPlatform (LlvmEnv (_, _, _, p)) = p
-- | Pretty print a 'CLabel'.
strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
-strCLabel_llvm env l
- = (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
+strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
+ (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
-- | Create an external definition for a 'CLabel' defined in another module.
genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 6ad9b72..83a2be7 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -41,7 +41,7 @@ type Section = (B.ByteString, B.ByteString)
-- | Read in assembly file and process
llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
-llvmFixupAsm dflags f1 f2 = do
+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
showPass dflags "LlVM Mangler"
r <- openBinaryFile f1 ReadMode
w <- openBinaryFile f2 WriteMode
More information about the Cvs-ghc
mailing list