-- -----------------------------------------------------------------------------
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm ( pprStmt, pprCmms, pprCmm )
-import MachOp
+import PprCmm
import CLabel
import State
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
-import FastTypes
import List ( groupBy, sortBy )
-import ErrUtils ( dumpIfSet_dyn )
import DynFlags
+#if powerpc_TARGET_ARCH
import StaticFlags ( opt_Static, opt_PIC )
+#endif
import Util
import Config ( cProjectVersion )
import Module
import Data.Maybe
import GHC.Exts
import Control.Monad
+import System.IO
{-
The native-code generator has machine-independent and
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
--- NB. We *lazilly* compile each block of code for space reasons.
-
--------------------
-nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
-nativeCodeGen dflags cmms us
+nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen dflags h us cmms
= do
- -- do native code generation on all these cmm things
- (us', result)
- <- mapAccumLM (cmmNativeGen dflags) us
- $ concat $ map add_split cmms
+ let split_cmms = concat $ map add_split cmms
- let (native, imports, mColorStats, mLinearStats)
- = unzip4 result
+ (imports, prof)
+ <- cmmNativeGens dflags h us split_cmms [] [] 0
+
+ let (native, colorStats, linearStats)
+ = unzip3 prof
+
+ -- dump native code
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm "Asm code"
+ (vcat $ map (docToSDoc . pprNatCmmTop) $ concat native)
-- dump global NCG stats for graph coloring allocator
- (case concat $ catMaybes mColorStats of
+ (case concat $ catMaybes colorStats of
[] -> return ()
stats -> do
-- build the global register conflict graph
-- dump global NCG stats for linear allocator
- (case catMaybes mLinearStats of
+ (case concat $ catMaybes linearStats of
[] -> return ()
stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
- $ Linear.pprStats (concat stats))
+ $ Linear.pprStats (concat native) stats)
+
+ -- write out the imports
+ Pretty.printDoc Pretty.LeftMode h
+ $ makeImportsDoc (concat imports)
+
+ return ()
+
+ where add_split (Cmm tops)
+ | dopt Opt_SplitObjs dflags = split_marker : tops
+ | otherwise = tops
+
+ split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
+
+
+-- | Do native code generation on all these cmms.
+--
+cmmNativeGens dflags h us [] impAcc profAcc count
+ = return (reverse impAcc, reverse profAcc)
+
+cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
+ = do
+ (us', native, imports, colorStats, linearStats)
+ <- cmmNativeGen dflags us cmm count
- return $ makeAsmDoc (concat native) (concat imports)
+ Pretty.printDoc Pretty.LeftMode h
+ $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
- where add_split (Cmm tops)
- | dopt Opt_SplitObjs dflags = split_marker : tops
- | otherwise = tops
+ let lsPprNative =
+ if dopt Opt_D_dump_asm dflags
+ || dopt Opt_D_dump_asm_stats dflags
+ then native
+ else []
- split_marker = CmmProc [] mkSplitMarkerLabel [] []
+ let count' = count + 1;
+
+
+ -- force evaulation all this stuff to avoid space leaks
+ seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
+ lsPprNative `seq` return ()
+ count' `seq` return ()
+
+ cmmNativeGens dflags h us' cmms
+ (imports : impAcc)
+ ((lsPprNative, colorStats, linearStats) : profAcc)
+ count'
+
+ where seqString [] = ()
+ seqString (x:xs) = x `seq` seqString xs `seq` ()
-- | Complete native code generation phase for a single top-level chunk of Cmm.
cmmNativeGen
:: DynFlags
-> UniqSupply
- -> RawCmmTop
- -> IO ( UniqSupply
- , ( [NatCmmTop]
- , [CLabel]
- , Maybe [Color.RegAllocStats]
- , Maybe [Linear.RegAllocStats]))
-
-cmmNativeGen dflags us cmm
+ -> RawCmmTop -- ^ the cmm to generate code for
+ -> Int -- ^ sequence number of this top thing
+ -> IO ( UniqSupply
+ , [NatCmmTop] -- native code
+ , [CLabel] -- things imported by this cmm
+ , Maybe [Color.RegAllocStats] -- stats for the coloring register allocator
+ , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+
+cmmNativeGen dflags us cmm count
= do
+
-- rewrite assignments to global regs
let (fixed_cmm, usFix) =
+ {-# SCC "fixAssignsTop" #-}
initUs us $ fixAssignsTop cmm
-- cmm to cmm optimisations
let (opt_cmm, imports) =
+ {-# SCC "cmmToCmm" #-}
cmmToCmm dflags fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmm $ Cmm [opt_cmm])
-
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
+ {-# SCC "genMachCode" #-}
initUs usFix $ genMachCode dflags opt_cmm
dumpIfSet_dyn dflags
-- tag instructions with register liveness information
let (withLiveness, usLive) =
+ {-# SCC "regLiveness" #-}
initUs usGen $ mapUs regLiveness native
dumpIfSet_dyn dflags
-- allocate registers
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
- if dopt Opt_RegsGraph dflags
+ if ( dopt Opt_RegsGraph dflags
+ || dopt Opt_RegsIterative dflags)
then do
-- the regs usable for allocation
let alloc_regs
emptyUFM
$ map RealReg allocatableRegs
- -- aggressively coalesce moves between virtual regs
- let (coalesced, usCoalesce)
- = initUs usLive $ regCoalesce withLiveness
-
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
- (vcat $ map ppr coalesced)
-
-- graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
- = initUs usCoalesce
- $ Color.regAlloc
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
+ $ Color.regAlloc
+ dflags
alloc_regs
(mkUniqSet [0..maxSpillSlots])
- coalesced
+ withLiveness
+ -- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (docToSDoc . pprNatCmmTop) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
(vcat $ map (\(stage, stats)
- -> text "-- Stage " <> int stage
+ -> text "# --------------------------"
+ $$ text "# cmm " <> int count <> text " Stage " <> int stage
$$ ppr stats)
$ zip [0..] regAllocStats)
+ let mPprStats =
+ if dopt Opt_D_dump_asm_stats dflags
+ then Just regAllocStats else Nothing
+
+ -- force evaluation of the Maybe to avoid space leak
+ mPprStats `seq` return ()
+
return ( alloced, usAlloc
- , if dopt Opt_D_dump_asm_stats dflags
- then Just regAllocStats else Nothing
+ , mPprStats
, Nothing)
else do
-- do linear register allocation
let ((alloced, regAllocStats), usAlloc)
- = initUs usLive
- $ liftM unzip
- $ mapUs Linear.regAlloc withLiveness
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
+ $ liftM unzip
+ $ mapUs Linear.regAlloc withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+ let mPprStats =
+ if dopt Opt_D_dump_asm_stats dflags
+ then Just (catMaybes regAllocStats) else Nothing
+
+ -- force evaluation of the Maybe to avoid space leak
+ mPprStats `seq` return ()
+
return ( alloced, usAlloc
, Nothing
- , if dopt Opt_D_dump_asm_stats dflags
- then Just (catMaybes regAllocStats) else Nothing)
+ , mPprStats)
---- shortcut branches
let shorted =
#endif
return ( usAlloc
- , ( final_mach_code
- , lastMinuteImports ++ imports
- , ppr_raStatsColor
- , ppr_raStatsLinear) )
+ , final_mach_code
+ , lastMinuteImports ++ imports
+ , ppr_raStatsColor
+ , ppr_raStatsLinear)
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop -> NatCmmTop
x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge top@(CmmProc info lbl params code) =
- CmmProc info lbl params (map bb_i386_insert_ffrees code)
- where
- bb_i386_insert_ffrees (BasicBlock id instrs) =
- BasicBlock id (i386_insert_ffrees instrs)
+x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
+ CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
--- | Build assembler source file from native code and its imports.
+-- | Build a doc for all the imports.
--
-makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc
-makeAsmDoc native imports
- = Pretty.vcat (map pprNatCmmTop native)
- Pretty.$$ (Pretty.text "")
- Pretty.$$ dyld_stubs imports
+makeImportsDoc :: [CLabel] -> Pretty.Doc
+makeImportsDoc imports
+ = dyld_stubs imports
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-- On recent versions of Darwin, the linker supports
sequenceTop :: NatCmmTop -> NatCmmTop
sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params blocks) =
- CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
+ CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
+
sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
-- the first block is the entry point ==> it must remain at the start.
sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
-sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
+sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
getOutEdges :: [Instr] -> [Unique]
getOutEdges instrs = case jumpDests (last instrs) [] of
mapping = foldr plusUFM emptyUFM mappings
build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl params [])
- = (CmmProc info lbl params [], emptyUFM)
-build_mapping (CmmProc info lbl params (head:blocks))
- = (CmmProc info lbl params (head:others), mapping)
+build_mapping (CmmProc info lbl params (ListGraph []))
+ = (CmmProc info lbl params (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
+ = (CmmProc info lbl params (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
where
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl params blocks)
- = CmmProc info lbl params (map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
+ = CmmProc info lbl params (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump (lookupUFM ufm) i
fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params blocks) =
+fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
- returnUs (CmmProc info lbl params blocks')
+ returnUs (CmmProc info lbl params (ListGraph blocks'))
fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
fixAssignsBlock (BasicBlock id stmts) =
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
+cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
- return $ CmmProc info lbl params blocks'
+ return $ CmmProc info lbl params (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
- args' <- mapM (\(arg, hint) -> do
+ args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
- return (arg', hint)) args
+ return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' srt returns
CmmCondBranch test dest
-> do
dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
- return $ cmmMachOpFold (MO_Add wordRep) [
+ return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
- (CmmLit $ CmmInt (fromIntegral off) wordRep)
+ (CmmLit $ CmmInt (fromIntegral off) wordWidth)
]
#if powerpc_TARGET_ARCH
-- On powerpc (non-PIC), it's easier to jump directly to a label than
-- to use the register table, so we replace these registers
-- with the corresponding labels:
+ CmmReg (CmmGlobal EagerBlackholeInfo)
+ | not opt_PIC
+ -> cmmExprConFold referenceKind $
+ CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO")))
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+ CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
#endif
CmmReg (CmmGlobal mid)
-> case mid of
BaseReg -> cmmExprConFold DataReference baseRegAddr
other -> cmmExprConFold DataReference
- (CmmLoad baseRegAddr (globalRegRep mid))
+ (CmmLoad baseRegAddr (globalRegType mid))
-- eliminate zero offsets
CmmRegOff reg 0
-> cmmExprConFold referenceKind (CmmReg reg)
-> case get_GlobalReg_reg_or_addr mid of
Left realreg -> return expr
Right baseRegAddr
- -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
+ -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [
CmmReg (CmmGlobal mid),
CmmLit (CmmInt (fromIntegral offset)
- wordRep)])
+ wordWidth)])
other
-> return other
projects / ghc-hetmet.git / blobdiff