Commit 6e3e64ae authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge remote-tracking branch 'origin/master' into tc-untouchables

parents 9a058b17 42cb30bd
......@@ -351,10 +351,9 @@ litIsDupable dflags (LitInteger i _) = inIntRange dflags i
litIsDupable _ _ = True
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
= fromInteger i <= ord minBound
&& fromInteger i >= ord maxBound
litFitsInChar _ = False
litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
&& i <= toInteger (ord maxBound)
litFitsInChar _ = False
litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
......
......@@ -13,7 +13,7 @@ module CLabel (
mkClosureLabel,
mkSRTLabel,
mkModSRTLabel,
mkTopSRTLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
......@@ -120,8 +120,6 @@ import DynFlags
import Platform
import UniqSet
import Data.Maybe (isJust)
-- -----------------------------------------------------------------------------
-- The CLabel type
......@@ -218,7 +216,7 @@ data CLabel
| HpcTicksLabel Module
-- | Static reference table
| SRTLabel (Maybe Module) !Unique
| SRTLabel !Unique
-- | Label of an StgLargeSRT
| LargeSRTLabel
......@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo
mkSlowEntryLabel :: Name -> CafInfo -> CLabel
mkSlowEntryLabel name c = IdLabel name c Slow
mkModSRTLabel :: Maybe Module -> Unique -> CLabel
mkModSRTLabel mb_mod u = SRTLabel mb_mod u
mkTopSRTLabel :: Unique -> CLabel
mkTopSRTLabel u = SRTLabel u
mkSRTLabel :: Name -> CafInfo -> CLabel
mkRednCountsLabel :: Name -> CafInfo -> CLabel
......@@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother
-- don't bother declaring Bitmap labels, we always make sure
-- they are defined before use.
needsCDecl (SRTLabel _ _) = True
needsCDecl (SRTLabel _) = True
needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
......@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel mb_mod _) = isJust mb_mod
externallyVisibleCLabel (SRTLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
......@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
labelType (SRTLabel _ _) = DataLabel
labelType (SRTLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
......@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext (sLit "_dflt")]
pprCLbl (SRTLabel mb_mod u)
= pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
| otherwise = empty
pprCLbl (SRTLabel u)
= pprUnique u <> pp_cSEP <> ptext (sLit "srt")
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
......
......@@ -14,28 +14,23 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal
, doSRTs, TopSRT, emptySRT, srtToData )
, doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
where
#include "HsVersions.h"
-- These should not be imported here!
import StgCmmUtils
import Hoopl
import Digraph
import qualified Prelude as P
import Prelude hiding (succ)
import BlockId
import Bitmap
import CLabel
import PprCmmDecl ()
import Cmm
import CmmUtils
import CmmInfo
import Data.List
import DynFlags
import Maybes
import Module
import Outputable
import SMRep
import UniqSupply
......@@ -47,6 +42,9 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad
import qualified Prelude as P
import Prelude hiding (succ)
foldSet :: (a -> b -> b) -> b -> Set a -> b
foldSet = Set.foldr
......@@ -137,11 +135,14 @@ instance Outputable TopSRT where
<+> ppr elts
<+> ppr eltmap
emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
emptySRT mb_mod =
do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
isEmptySRT :: TopSRT -> Bool
isEmptySRT srt = null (rev_elts srt)
cafMember :: TopSRT -> CLabel -> Bool
cafMember srt lbl = Map.member lbl (elt_map srt)
......@@ -228,7 +229,7 @@ maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT dflags top_srt off len bmp
| len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))]
| len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
......@@ -236,7 +237,7 @@ to_SRT dflags top_srt off len bmp
( cmmLabelOffW dflags top_srt off
: mkWordCLit dflags (toStgWord dflags (fromIntegral len))
: map (mkWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 (srt_escape dflags))
return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
| otherwise
= return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
-- The fromIntegral converts to StgHalfWord
......
......@@ -9,6 +9,7 @@ module CmmInfo (
mkEmptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
srtEscape
) where
#include "HsVersions.h"
......@@ -384,3 +385,9 @@ newStringLit bytes
= do { uniq <- getUniqueUs
; return (mkByteStringCLit uniq bytes) }
-- Misc utils
-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags = toStgHalfWord dflags (-1)
......@@ -3,8 +3,9 @@ module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
import StgCmmLayout ( entryCode ) -- XXX layering violation
import Cmm
import BlockId
......@@ -939,7 +940,8 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags)
jump = CmmCall { cml_target = entryCode dflags $
CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
......
......@@ -7,8 +7,6 @@
-----------------------------------------------------------------------------
module CmmOpt (
cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmMachOpFoldM,
cmmLoopifyForC,
......@@ -17,282 +15,15 @@ module CmmOpt (
#include "HsVersions.h"
import OldCmm
import OldPprCmm
import CmmNode (wrapRecExp)
import CmmUtils
import DynFlags
import CLabel
import UniqFM
import Unique
import Util
import FastTypes
import Outputable
import Platform
import BlockId
import Data.Bits
import Data.Maybe
import Data.List
-- -----------------------------------------------------------------------------
-- Eliminates dead blocks
{-
We repeatedly expand the set of reachable blocks until we hit a
fixpoint, and then prune any blocks that were not in this set. This is
actually a required optimization, as dead blocks can cause problems
for invariants in the linear register allocator (and possibly other
places.)
-}
-- Deep fold over statements could probably be abstracted out, but it
-- might not be worth the effort since OldCmm is moribund
cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
cmmEliminateDeadBlocks [] = []
cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
let -- Calculate what's reachable from what block
reachableMap = foldl' f emptyUFM blocks -- lazy in values
where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
reachableFrom stmts = foldl stmt [] stmts
where
stmt m CmmNop = m
stmt m (CmmComment _) = m
stmt m (CmmAssign _ e) = expr m e
stmt m (CmmStore e1 e2) = expr (expr m e1) e2
stmt m (CmmCall c _ as _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _ Nothing) = m
f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts
stmt m (CmmBranch b) = b:m
stmt m (CmmCondBranch e b) = b:(expr m e)
stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e _) = expr m e
stmt m (CmmReturn) = m
actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
-- We have to do a deep fold into CmmExpr because
-- there may be a BlockId in the CmmBlock literal.
expr m (CmmLit l) = lit m l
expr m (CmmLoad e _) = expr m e
expr m (CmmReg _) = m
expr m (CmmMachOp _ es) = foldl' expr m es
expr m (CmmStackSlot _ _) = m
expr m (CmmRegOff _ _) = m
lit m (CmmBlock b) = b:m
lit m _ = m
-- go todo done
reachable = go [base_id] (setEmpty :: BlockSet)
where go [] m = m
go (x:xs) m
| setMember x m = go xs m
| otherwise = go (add ++ xs) (setInsert x m)
where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
(lookupUFM reachableMap x)
in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner
{-
This pass inlines assignments to temporaries. Temporaries that are
only used once are unconditionally inlined. Temporaries that are used
two or more times are only inlined if they are assigned a literal. It
works as follows:
- count uses of each temporary
- for each temporary:
- attempt to push it forward to the statement that uses it
- only push forward past assignments to other temporaries
(assumes that temporaries are single-assignment)
- if we reach the statement that uses it, inline the rhs
and delete the original assignment.
[N.B. In the Quick C-- compiler, this optimization is achieved by a
combination of two dataflow passes: forward substitution (peephole
optimization) and dead-assignment elimination. ---NR]
Possible generalisations: here is an example from factorial
Fac_zdwfac_entry:
cmG:
_smi = R2;
if (_smi != 0) goto cmK;
R1 = R3;
jump I64[Sp];
cmK:
_smn = _smi * R3;
R2 = _smi + (-1);
R3 = _smn;
jump Fac_zdwfac_info;
We want to inline _smi and _smn. To inline _smn:
- we must be able to push forward past assignments to global regs.
We can do this if the rhs of the assignment we are pushing
forward doesn't refer to the global reg being assigned to; easy
to test.
To inline _smi:
- It is a trivial replacement, reg for reg, but it occurs more than
once.
- We can inline trivial assignments even if the temporary occurs
more than once, as long as we don't eliminate the original assignment
(this doesn't help much on its own).
- We need to be able to propagate the assignment forward through jumps;
if we did this, we would find that it can be inlined safely in all
its occurrences.
-}
countUses :: UserOfLocalRegs a => a -> UniqFM Int
countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a
cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
cmmMiniInline dflags blocks = map do_inline blocks
where do_inline (BasicBlock id stmts)
= BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts)
cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts _ _ [] = []
cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
-- not used: just discard this assignment
| 0 <- lookupWithDefaultUFM uses 0 u
= cmmMiniInlineStmts dflags uses stmts
-- used (foldable to small thing): try to inline at all the use sites
| Just n <- lookupUFM uses u,
e <- wrapRecExp foldExp expr,
isTiny e
=
ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
case lookForInlineMany u e stmts of
(m, stmts')
| n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
| otherwise ->
stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
-- used once (non-literal): try to inline at the use site
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $
cmmMiniInlineStmts dflags uses stmts'
where
isTiny (CmmLit _) = True
isTiny (CmmReg (CmmGlobal _)) = True
-- not CmmLocal: that might invalidate the usage analysis results
isTiny _ = False
foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args
foldExp e = e
ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x
cmmMiniInlineStmts platform uses (stmt:stmts)
= stmt : cmmMiniInlineStmts platform uses stmts
-- | Takes a register, a 'CmmLit' expression assigned to that
-- register, and a list of statements. Inlines the expression at all
-- use sites of the register. Returns the number of substituations
-- made and the, possibly modified, list of statements.
lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts
where regset = foldRegsUsed extendRegSet emptyRegSet expr
lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt])
lookForInlineMany' _ _ _ [] = (0, [])
lookForInlineMany' u expr regset stmts@(stmt : rest)
| Just n <- lookupUFM (countUses stmt) u, okToInline expr stmt
= let stmt' = inlineStmt u expr stmt in
if okToSkip stmt' u expr regset
then case lookForInlineMany' u expr regset rest of
(m, stmts) -> let z = n + m
in z `seq` (z, stmt' : stmts)
else (n, stmt' : rest)
| okToSkip stmt u expr regset
= case lookForInlineMany' u expr regset rest of
(n, stmts) -> (n, stmt : stmts)
| otherwise
= (0, stmts)
lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt]
lookForInline u expr stmts = lookForInline' u expr regset stmts
where regset = foldRegsUsed extendRegSet emptyRegSet expr
lookForInline' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> Maybe [CmmStmt]
lookForInline' _ _ _ [] = panic "lookForInline' []"
lookForInline' u expr regset (stmt : rest)
| Just 1 <- lookupUFM (countUses stmt) u, okToInline expr stmt
= Just (inlineStmt u expr stmt : rest)
| okToSkip stmt u expr regset
= case lookForInline' u expr regset rest of
Nothing -> Nothing
Just stmts -> Just (stmt:stmts)
| otherwise
= Nothing
-- we don't inline into CmmCall if the expression refers to global
-- registers. This is a HACK to avoid global registers clashing with
-- C argument-passing registers, really the back-end ought to be able
-- to handle it properly, but currently neither PprC nor the NCG can
-- do it. See also CgForeignCall:load_args_into_temps.
okToInline :: CmmExpr -> CmmStmt -> Bool
okToInline expr CmmCall{} = hasNoGlobalRegs expr
okToInline _ _ = True
-- Expressions aren't side-effecting. Temporaries may or may not
-- be single-assignment depending on the source (the old code
-- generator creates single-assignment code, but hand-written Cmm
-- and Cmm from the new code generator is not single-assignment.)
-- So we do an extra check to make sure that the register being
-- changed is not one we were relying on. I don't know how much of a
-- performance hit this is (we have to create a regset for every
-- instruction.) -- EZY
okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool
okToSkip stmt u expr regset
= case stmt of
CmmNop -> True
CmmComment{} -> True
CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True
CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr)
CmmStore _ _ -> not_a_load expr
_other -> False
where
not_a_load (CmmMachOp _ args) = all not_a_load args
not_a_load (CmmLoad _ _) = False
not_a_load _ = True
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
inlineStmt u a (CmmCall target regs es ret)
= CmmCall (infn target) regs es' ret
where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts)
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live
inlineStmt _ _ other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
| u == u' = a
| otherwise = e
inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
| u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)]
| otherwise = e
where
width = typeWidth rep
inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
inlineExpr _ _ other_expr = other_expr
-- -----------------------------------------------------------------------------
-- MachOp constant folder
......
......@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info -----------------
......
......@@ -11,6 +11,7 @@ where
import Prelude hiding (last, unzip, succ, zip)
import DynFlags
import BlockId
import CLabel
import Cmm
......@@ -26,8 +27,6 @@ import UniqSupply
import Hoopl
import qualified Data.Map as Map
-- Compute a minimal set of proc points for a control-flow graph.
-- Determine a protocol for each proc point (which live variables will
......@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap
splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
......@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = Map.insert pp lbls map
let add_label map pp = mapInsert pp lbls map
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp))
procLabels = foldl add_label Map.empty
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = foldl add_label mapEmpty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
......@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
_ -> rst
add_if_pp id rst = case Map.lookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
jump_label (Just info_lbl) _
| tablesNextToCode dflags = info_lbl
| otherwise = toEntryLbl info_lbl
jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
Nothing -> rst
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (mapEmpty, []) needed_jumps
......@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
......@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) =
case Map.lookup bid procLabels of
case mapLookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e
repl e = e
......@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
......
......@@ -15,10 +15,11 @@ module CmmRewriteAssignments