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
let split_cmms = concat $ map add_split cmms
(imports, prof)
- <- cmmNativeGens dflags h us split_cmms [] []
+ <- cmmNativeGens dflags h us split_cmms [] [] 0
let (native, colorStats, linearStats)
= unzip3 prof
-- | Do native code generation on all these cmms.
--
-cmmNativeGens dflags h us [] impAcc profAcc
+cmmNativeGens dflags h us [] impAcc profAcc count
= return (reverse impAcc, reverse profAcc)
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
+cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
= do
(us', native, imports, colorStats, linearStats)
- <- cmmNativeGen dflags us cmm
+ <- cmmNativeGen dflags us cmm count
Pretty.printDoc Pretty.LeftMode h
$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
then native
else []
- -- force evaulation of imports and lsPprNative to avoid space leak
+ let count' = count + 1;
+
+
+ -- force evaulation all this stuff to avoid space leaks
seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
- lsPprNative `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` ()
cmmNativeGen
:: DynFlags
-> UniqSupply
- -> RawCmmTop
+ -> RawCmmTop -- ^ the cmm to generate code for
+ -> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply
- , [NatCmmTop]
- , [CLabel]
- , Maybe [Color.RegAllocStats]
- , Maybe [Linear.RegAllocStats])
+ , [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
+cmmNativeGen dflags us cmm count
= do
+
-- rewrite assignments to global regs
let (fixed_cmm, usFix) =
{-# SCC "fixAssignsTop" #-}
-- 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
- -- if any of these dump flags are turned on we want to hang on to
- -- intermediate structures in the allocator - otherwise tell the
- -- allocator to ditch them early so we don't end up creating space leaks.
- let generateRegAllocStats = or
- [ dopt Opt_D_dump_asm_regalloc_stages dflags
- , dopt Opt_D_dump_asm_stats dflags
- , dopt Opt_D_dump_asm_conflicts dflags ]
-
-- graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
- = {-# SCC "RegAlloc(color)" #-}
+ = {-# SCC "RegAlloc" #-}
initUs usLive
$ Color.regAlloc
- generateRegAllocStats
+ dflags
alloc_regs
(mkUniqSet [0..maxSpillSlots])
withLiveness
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)
else do
-- do linear register allocation
let ((alloced, regAllocStats), usAlloc)
- = {-# SCC "RegAlloc(linear)" #-}
+ = {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
$ mapUs Linear.regAlloc withLiveness
x86fp_kludge :: NatCmmTop -> NatCmmTop
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
- CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code)
- where
- bb_i386_insert_ffrees (BasicBlock id instrs) =
- BasicBlock id (i386_insert_ffrees instrs)
+ CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
-- 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
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