-- -----------------------------------------------------------------------------
\begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# 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/WorkingConventions#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module AsmCodeGen ( nativeCodeGen ) where
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
- split_marker = CmmProc [] mkSplitMarkerLabel [] []
+ split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
-- | Do native code generation on all these cmms.
else []
-- force evaulation of imports and lsPprNative to avoid space leak
- seqString (showSDoc $ vcat $ map ppr imports)
- `seq` lsPprNative
- `seq` cmmNativeGens dflags h us' cmms
+ seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
+ lsPprNative `seq` return ()
+
+ cmmNativeGens dflags h us' cmms
(imports : impAcc)
((lsPprNative, colorStats, linearStats) : profAcc)
emptyUFM
$ map RealReg allocatableRegs
- -- aggressively coalesce moves between virtual regs
- let (coalesced, usCoalesce)
- = {-# SCC "regCoalesce" #-}
- initUs usLive $ regCoalesce withLiveness
-
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
- (vcat $ map ppr coalesced)
-
-- 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.
-- graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
- = {-# SCC "regAlloc(color)" #-}
- initUs usCoalesce
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
$ Color.regAlloc
generateRegAllocStats
alloc_regs
(mkUniqSet [0..maxSpillSlots])
- coalesced
+ withLiveness
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
then Just regAllocStats else Nothing
-- force evaluation of the Maybe to avoid space leak
- mPprStats
- `seq` return ( alloced, usAlloc
- , mPprStats
- , Nothing)
+ mPprStats `seq` return ()
+
+ return ( alloced, usAlloc
+ , mPprStats
+ , Nothing)
else do
-- do linear register allocation
let ((alloced, regAllocStats), usAlloc)
- = {-# SCC "regAlloc(linear)" #-}
+ = {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
$ mapUs Linear.regAlloc withLiveness
then Just (catMaybes regAllocStats) else Nothing
-- force evaluation of the Maybe to avoid space leak
- mPprStats
- `seq` return ( alloced, usAlloc
- , Nothing
- , mPprStats)
+ mPprStats `seq` return ()
+
+ return ( alloced, usAlloc
+ , Nothing
+ , mPprStats)
---- shortcut branches
let shorted =
#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)
+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)
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
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] #))
projects / ghc-hetmet.git / blobdiff