Skip to content

GitLab

Commit 6f346d4d authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents cc3d9828 a25c9741
Hide whitespace changes
Inline Side-by-side
compiler/cmm/Cmm.hs
View file @ 6f346d4d
......@@ -14,7 +14,7 @@ module Cmm (
CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
-- * Info Tables
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..),
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
ClosureTypeInfo(..),
C_SRT(..), needsSRT,
ProfilingInfo(..), ConstrDescription,
......@@ -96,17 +96,23 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo { info_tbl :: CmmInfoTable
data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable
, stack_info :: CmmStackInfo }
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
data CmmStackInfo
= StackInfo {
arg_space :: ByteOff,
-- number of bytes of arguments on the stack on entry to the
-- the proc. This is filled in by StgCmm.codeGen, and used
-- by the stack allocator later.
updfr_space :: Maybe ByteOff -- XXX: comment?
}
updfr_space :: Maybe ByteOff
-- XXX: this never contains anything useful, but it should.
-- See comment in CmmLayoutStack.
}
-- | Info table as a haskell data type
data CmmInfoTable
......@@ -116,7 +122,6 @@ data CmmInfoTable
cit_prof :: ProfilingInfo,
cit_srt :: C_SRT
}
| CmmNonInfoTable -- Procedure doesn't need an info table
data ProfilingInfo
= NoProfilingInfo
......
compiler/cmm/CmmBuildInfoTables.hs
View file @ 6f346d4d
......@@ -50,21 +50,9 @@ import Control.Monad
foldSet :: (a -> b -> b) -> b -> Set a -> b
foldSet = Set.foldr
----------------------------------------------------------------
-- Building InfoTables
-----------------------------------------------------------------------
-- SRTs
-- WE NEED AN EXAMPLE HERE.
-- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
-- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
-- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
-- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
-- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
-- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
{- EXAMPLE
f = \x. ... g ...
......@@ -100,7 +88,7 @@ h_closure with their contents:
[ g_entry{c2_closure, c1_closure} ]
[ h_entry{c2_closure} ]
This is what mkTopCAFInfo is doing.
This is what flattenCAFSets is doing.
-}
......@@ -179,8 +167,8 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT cafs =
buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT topSRT cafs =
do let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
......@@ -261,9 +249,9 @@ to_SRT top_srt off len bmp
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of
CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
case topInfoTable proc of
Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
-> (cafs, Just (toClosureLbl top_l))
_other -> (cafs, Nothing)
where
......@@ -304,16 +292,30 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset
bundle :: Map CLabel CAFSet
-> (CAFEnv, CmmDecl)
-> (CAFSet, Maybe CLabel)
-> (CAFSet, CmmDecl)
bundle flatmap (_, decl) (cafs, Nothing)
= (flatten flatmap cafs, decl)
bundle flatmap (_, decl) (_, Just l)
= (expectJust "bundle" $ Map.lookup l flatmap, decl)
-> (BlockEnv CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
= ( mapMapWithKey get_cafs (info_tbls infos), decl )
where
entry = g_entry g
entry_cafs
| Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
| otherwise = flatten flatmap closure_cafs
get_cafs l _
| l == entry = entry_cafs
| otherwise = if not (mapMember l env)
then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
else flatten flatmap $ expectJust "bundle" $ mapLookup l env
bundle _flatmap (_, decl) _
= ( mapEmpty, decl )
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
where
zipped = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
localCAFs = unzipWith localCAFInfo zipped
flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
......@@ -328,15 +330,35 @@ doSRTs topSRT tops
let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
return (topSRT', reverse gs' {- Note [reverse gs] -})
where
setSRT (topSRT, rst) (cafs, decl@(CmmProc{})) = do
(topSRT, cafTable, srt) <- buildSRTs topSRT cafs
let decl' = updInfo (const srt) decl
case cafTable of
Just tbl -> return (topSRT, decl': tbl : rst)
Nothing -> return (topSRT, decl' : rst)
setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
(topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map
let decl' = updInfoSRTs srt_env decl
return (topSRT, decl': srt_tables ++ rst)
setSRT (topSRT, rst) (_, decl) =
return (topSRT, decl : rst)
buildSRTs :: TopSRT -> BlockEnv CAFSet
-> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
buildSRTs top_srt caf_map
= foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
where
doOne (top_srt, decls, srt_env) (l, cafs)
= do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs
return ( top_srt, maybeToList mb_decl ++ decls
, mapInsert l srt srt_env )
{-
- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
- The one corresponding to g_entry is the closure info table, the
rest are continuations.
- Each one needs an SRT.
- We get the CAFSet for each one from the CAFEnv
- flatten gives us
[(BlockEnv CAFSet, CmmDecl)]
-
-}
{- Note [reverse gs]
It is important to keep the code blocks in the same order,
......@@ -345,12 +367,9 @@ doSRTs topSRT tops
instructions for forward refs. --SDM
-}
updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
updInfo toSrt (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g
updInfo _ t = t
updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toSrt info_tbl@(CmmInfoTable {})
= info_tbl { cit_srt = toSrt (cit_srt info_tbl) }
updInfoTbl _ t@CmmNonInfoTable = t
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
where updInfoTbl l info_tbl
= info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t
compiler/cmm/CmmContFlowOpt.hs
View file @ 6f346d4d
......@@ -25,14 +25,26 @@ import Prelude hiding (succ, unzip, zip)
-----------------------------------------------------------------------------
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat
cmmCfgOpts g = fst (blockConcat g)
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts
cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl g'
where (g', env) = blockConcat g
info' = info{ info_tbls = new_info_tbls }
new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top
-- If we changed any labels, then we have to update the info tables
-- too, except for the top-level info table because that might be
-- referred to by other procs.
upd_info (k,info)
| Just k' <- mapLookup k env
= (k', if k' == g_entry g'
then info
else info{ cit_lbl = infoTblLbl k' })
| otherwise
= (k,info)
cmmCfgOptsProc top = top
-----------------------------------------------------------------------------
......@@ -41,7 +53,7 @@ optProc _ top = top
--
-----------------------------------------------------------------------------
-- This optimisation does two things:
-- This optimisation does three things:
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
......@@ -52,6 +64,10 @@ optProc _ top = top
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
--
-- - removes any unreachable blocks from the graph. This is a side
-- effect of starting with a postorder DFS traversal of the graph
--
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.
......@@ -77,9 +93,9 @@ optProc _ top = top
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat :: CmmGraph -> CmmGraph
blockConcat :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
= (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
where
-- we might be able to shortcut the entry BlockId itself
new_entry
......@@ -90,9 +106,12 @@ blockConcat g@CmmGraph { g_entry = entry_id }
= entry_id
blocks = postorderDfs g
blockmap = foldr addBlock emptyBody blocks
-- the initial blockmap is constructed from the postorderDfs result,
-- so that we automatically throw away unreachable blocks.
(new_blocks, shortcut_map) =
foldr maybe_concat (toBlockMap g, mapEmpty) blocks
foldr maybe_concat (blockmap, mapEmpty) blocks
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
......
compiler/cmm/CmmCvt.hs
View file @ 6f346d4d
......@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbl h) l (ofZgraph g)
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
data ValueDirection = Arguments | Results
......
compiler/cmm/CmmInfo.hs
View file @ 6f346d4d
......@@ -21,6 +21,7 @@ import SMRep
import Bitmap
import Stream (Stream)
import qualified Stream
import Hoopl
import Maybes
import Constants
......@@ -90,17 +91,63 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable dflags (CmmProc info entry_label blocks)
| CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info
= do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
| otherwise = panic "mkInfoTable"
-- Patern match overlap check not clever enough
mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
--
-- in the non-tables-next-to-code case, procs can have at most a
-- single info table associated with the entry label of the proc.
--
| not tablesNextToCode
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
return [CmmProc mapEmpty entry_lbl blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags info Nothing
let
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
--
case blocks of
ListGraph [] ->
-- No code; only the info table is significant
-- Use a zero place-holder in place of the
-- entry-label in the info table
return (top_decls ++
[mkRODataLits info_lbl (zeroCLit : rel_std_info ++
rel_extra_bits)])
_nonempty ->
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
return (top_decls ++
[CmmProc mapEmpty entry_lbl blocks,
mkDataLits Data info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
--
-- With tables-next-to-code, we can have many info tables,
-- associated with some of the BlockIds of the proc. For each info
-- table we need to turn it into CmmStatics, and collect any new
-- CmmDecls that arise from doing so.
--
| otherwise
= do
(top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl blocks])
where
do_one_info (lbl,itbl) = do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags itbl Nothing
let
info_lbl = cit_lbl itbl
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
--
return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
type InfoTableContents = ( [CmmLit] -- The standard part
......@@ -207,36 +254,6 @@ mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)
-- * the code
-- and lays them out in memory, producing a list of RawCmmDecl
-- The value of tablesNextToCode determines the relative positioning
-- of the extra bits and the standard info table, and whether the
-- former is reversed or not. It also decides whether pointers in the
-- info table should be expressed as offsets relative to the info
-- pointer or not (see "Position Independent Code" below.
mkInfoTableAndCode :: CLabel -- Info table label
-> InfoTableContents
-> CLabel -- Entry label
-> ListGraph CmmStmt -- Entry code
-> [RawCmmDecl]
mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
= [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info)
entry_lbl blocks]
| ListGraph [] <- blocks -- No code; only the info table is significant
= -- Use a zero place-holder in place of the
-- entry-label in the info table
[mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
| otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code
[CmmProc Nothing entry_lbl blocks,
mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]
where
rel_std_info = map (makeRelativeRefTo info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
-------------------------------------------------------------------------
--
-- Position independent code
......
compiler/cmm/CmmLayoutStack.hs
View file @ 6f346d4d
......@@ -211,11 +211,29 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
acc_stackmaps' = mapUnion acc_stackmaps out
hwm' = maximum (acc_hwm : (sp0 - sp_off) : map sm_sp (mapElems out))
-- If this block jumps to the GC, then we do not take its
-- stack usage into account for the high-water mark.
-- Otherwise, if the only stack usage is in the stack-check
-- failure block itself, we will do a redundant stack
-- check. The stack has a buffer designed to accommodate
-- the largest amount of stack needed for calling the GC.
--
this_sp_hwm | isGcJump last0 = 0
| otherwise = sp0 - sp_off
hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
-- -----------------------------------------------------------------------------
-- Not foolproof, but GCFun is the culprit we most want to catch
isGcJump :: CmmNode O C -> Bool
isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
= l == GCFun || l == GCEnter1
isGcJump _something_else = False
-- -----------------------------------------------------------------------------
-- This doesn't seem right somehow. We need to find out whether this
......@@ -325,9 +343,9 @@ handleLastNode procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl wORD_SIZE wORD_SIZE (sm_ret_off stack0)
-- one word each for args and results: the return address
CmmBranch{..} -> handleProcPoints
CmmCondBranch{..} -> handleProcPoints
CmmSwitch{..} -> handleProcPoints
CmmBranch{..} -> handleBranches
CmmCondBranch{..} -> handleBranches
CmmSwitch{..} -> handleBranches
where
-- Calls and ForeignCalls are handled the same way:
......@@ -365,13 +383,13 @@ handleLastNode procpoints liveness cont_info stackmaps
-- proc point, we have to set up the stack to match what the proc
-- point is expecting.
--
handleProcPoints :: UniqSM ( [CmmNode O O]
handleBranches :: UniqSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, BlockEnv StackMap )
handleProcPoints
handleBranches
-- Note [diamond proc point]
| Just l <- futureContinuation middle
, (nub $ filter (`setMember` procpoints) $ successors last) == [l]
......@@ -387,52 +405,65 @@ handleLastNode procpoints liveness cont_info stackmaps
, out)
| otherwise = do
pps <- mapM handleProcPoint (successors last)
pps <- mapM handleBranch (successors last)
let lbl_map :: LabelMap Label
lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
fix_lbl l = mapLookup l lbl_map `orElse` l
fix_lbl l = mapFindWithDefault l l lbl_map
return ( []
, 0
, mapSuccessors fix_lbl last
, concat [ blk | (_,_,_,blk) <- pps ]
, mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
-- For each proc point that is a successor of this block
-- (a) if the proc point already has a stackmap, we need to
-- shuffle the current stack to make it look the same.
-- We have to insert a new block to make this happen.
-- (b) otherwise, call "allocate live stack0" to make the
-- stack map for the proc point
handleProcPoint :: BlockId
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleProcPoint l
| not (l `setMember` procpoints) = return (l, l, stack0, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let
(stack2, assigs) =
case mapLookup l stackmaps of
Just pp_sm -> (pp_sm, fixupStack stack0 pp_sm)
Nothing ->
-- For each successor of this block
handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch l
-- (a) if the successor already has a stackmap, we need to
-- shuffle the current stack to make it look the same.
-- We have to insert a new block to make this happen.
| Just stack2 <- mapLookup l stackmaps
= do
let assigs = fixupStack stack0 stack2
(tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (b) if the successor is a proc point, save everything
-- on the stack.
| l `setMember` procpoints
= do
let cont_args = mapFindWithDefault 0 l cont_info
(stack2, assigs) =
--pprTrace "first visit to proc point"
-- (ppr l <+> ppr stack1) $
(stack1, assigs)
where
cont_args = mapFindWithDefault 0 l cont_info
(stack1, assigs) =
setupStackFrame l liveness (sm_ret_off stack0)
setupStackFrame l liveness (sm_ret_off stack0)
cont_args stack0
sp_off = sp0 - sm_sp stack2
block = blockJoin (CmmEntry tmp_lbl)
(maybeAddSpAdj sp_off (blockFromList assigs))
(CmmBranch l)
--
return (l, tmp_lbl, stack2, [block])
--
(tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (c) otherwise, the current StackMap is the StackMap for
-- the continuation. But we must remember to remove any
-- variables from the StackMap that are *not* live at
-- the destination, because this StackMap might be used
-- by fixupStack if this is a join point.
| otherwise = return (l, l, stack1, [])
where live = mapFindWithDefault (panic "handleBranch") l liveness
stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
is_live (r,_) = r `elemRegSet` live
makeFixupBlock :: ByteOff -> Label -> StackMap -> [CmmNode O O] -> UniqSM (Label, [CmmBlock])
makeFixupBlock sp0 l stack assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl)
(maybeAddSpAdj sp_off (blockFromList assigs))
(CmmBranch l)
return (tmp_lbl, [block])
-- Sp is currently pointing to current_sp,
-- we want it to point to
-- (sm_sp cont_stack - sm_args cont_stack + args)
......@@ -807,18 +838,17 @@ elimStackStores stackmap stackmaps area_off nodes
setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap stackmaps
(CmmProc top_info@TopInfo{..} l g@CmmGraph{g_entry = eid})
= CmmProc top_info{ info_tbl = fix_info info_tbl } l g
setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
where
fix_info info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness eid) }
fix_info other = other
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
info_tbl { cit_rep = StackRep (get_liveness lbl) }
fix_info _ other = other
get_liveness :: BlockId -> Liveness
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl)
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
Just sm -> stackMapToLiveness sm
setInfoTableStackMap _ d = d
......
compiler/cmm/CmmOpt.hs
View file @ 6f346d4d
......@@ -22,6 +22,7 @@ import CmmNode (wrapRecExp)
import CmmUtils
import DynFlags
import StaticFlags
import CLabel
import UniqFM
import Unique
......@@ -667,11 +668,12 @@ exactLog2 x_
-}
cmmLoopifyForC :: RawCmmDecl -> RawCmmDecl
cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
-- XXX: revisit if we actually want to do this
-- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts
cmmLoopifyForC (CmmProc infos entry_lbl
(ListGraph blocks@(BasicBlock top_id _ : _))) =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
CmmProc (Just info) entry_lbl (ListGraph blocks')
CmmProc infos entry_lbl (ListGraph blocks')