Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/90d2acd1691d3398dc6cbc51ef9b43f037aef1fe >--------------------------------------------------------------- commit 90d2acd1691d3398dc6cbc51ef9b43f037aef1fe Author: David Terei <[email protected]> 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
