Skip to content

GitLab

Commit 322044b2 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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

parents fb0769b6 0f693381
Hide whitespace changes
Inline Side-by-side
Showing with 646 additions and 302 deletions
compiler/cmm/CmmBuildInfoTables.hs
View file @ 322044b2
......@@ -13,17 +13,15 @@
-- Todo: remove -fno-warn-warnings-deprecations
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT
, TopSRT, emptySRT, srtToData
, bundleCAFs
, cafTransfers )
( CAFSet, CAFEnv, cafAnal
, doSRTs, TopSRT, emptySRT, srtToData )
where
#include "HsVersions.h"
-- These should not be imported here!
import StgCmmUtils
import Hoopl
import Digraph
import qualified Prelude as P
......@@ -41,13 +39,13 @@ import Name
import Outputable
import SMRep
import UniqSupply
import Hoopl
import Util
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad
foldSet :: (a -> b -> b) -> b -> Set a -> b
#if __GLASGOW_HASKELL__ < 704
......@@ -71,6 +69,44 @@ foldSet = Set.foldr
-- 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 ...
where
g = \y. ... h ... c1 ...
h = \z. ... c2 ...
c1 & c2 are CAFs
g and h are local functions, but they have no static closures. When
we generate code for f, we start with a CmmGroup of four CmmDecls:
[ f_closure, f_entry, g_entry, h_entry ]
we process each CmmDecl separately in cpsTop, giving us a list of
CmmDecls. e.g. for f_entry, we might end up with
[ f_entry, f1_ret, f2_proc ]
where f1_ret is a return point, and f2_proc is a proc-point. We have
a CAFSet for each of these CmmDecls, let's suppose they are
[ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
[ g_entry{h_closure, c1_closure} ]
[ h_entry{c2_closure} ]
Now, note that we cannot use g_closure and h_closure in an SRT,
because there are no static closures corresponding to these functions.
So we have to flatten out the structure, replacing g_closure and
h_closure with their contents:
[ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
[ g_entry{c2_closure, c1_closure} ]
[ h_entry{c2_closure} ]
This is what mkTopCAFInfo is doing.
-}
-----------------------------------------------------------------------
-- Finding the CAFs used by a procedure
......@@ -147,16 +183,13 @@ 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 -> Map CLabel CAFSet -> CAFSet ->
UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
Nothing -> Set.insert lbl z
buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs 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.
sub_srt topSRT localCafs =
let cafs = Set.elems (foldSet liftCAF Set.empty localCafs)
let cafs = Set.elems localCafs
mkSRT topSRT =
do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
return (topSRT, localSRTs)
......@@ -230,15 +263,15 @@ to_SRT top_srt off len bmp
-- keep its CAFs live.)
-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
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)
-> Just (toClosureLbl top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing
CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
-> (cafs, Just (toClosureLbl top_l))
_other -> (cafs, Nothing)
where
cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
-- Once we have the local CAF sets for some (possibly) mutually
-- recursive functions, we can create an environment mapping
......@@ -251,54 +284,77 @@ localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
-- the environment with every reference to f replaced by its set of CAFs.
-- To do this replacement efficiently, we gather strongly connected
-- components, then we sort the components in topological order.
mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
where addToTop env (AcyclicSCC (l, cafset)) =
where
addToTop env (AcyclicSCC (l, cafset)) =
Map.insert l (flatten env cafset) env
addToTop env (CyclicSCC nodes) =
let (lbls, cafsets) = unzip nodes
cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
flatten env cafset = foldSet (lookup env) Set.empty cafset
lookup env caf cafset' =
case Map.lookup caf env of Just cafs -> foldSet add cafset' cafs
Nothing -> add caf cafset'
add caf cafset' = Set.insert caf cafset'
g = stronglyConnCompFromEdgedVertices
(map (\n@(l, cafs) -> (n, l, Set.elems cafs)) localCAFs)
-- Bundle the CAFs used at a procpoint.
bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl)
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
(expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
bundleCAFs _ t = (Set.empty, t)
-- Construct the SRTs for the given procedure.
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
UniqSM (TopSRT, [CmmDecl])
setInfoTableSRT topCAFMap topSRT (cafs, t) =
setSRT cafs topCAFMap topSRT t
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
CmmDecl -> UniqSM (TopSRT, [CmmDecl])
setSRT cafs topCAFMap topSRT t =
do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
let t' = updInfo id (const srt) t
case cafTable of
Just tbl -> return (topSRT, [t', tbl])
Nothing -> return (topSRT, [t'])
type StackLayout = Liveness
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
updInfo toVars toSrt (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
updInfo _ _ t = t
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
= info_tbl { cit_srt = toSrt (cit_srt info_tbl)
, cit_rep = case cit_rep info_tbl of
StackRep ls -> StackRep (toVars ls)
other -> other }
updInfoTbl _ _ t@CmmNonInfoTable = t
[ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
flatten env cafset = foldSet (lookup env) Set.empty cafset
where
lookup env caf cafset' =
case Map.lookup caf env of
Just cafs -> foldSet Set.insert cafset' cafs
Nothing -> Set.insert caf 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)
flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
where
zipped = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
localCAFs = unzipWith localCAFInfo zipped
flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
doSRTs :: TopSRT
-> [(CAFEnv, [CmmDecl])]
-> IO (TopSRT, [CmmDecl])
doSRTs topSRT tops
= do
let caf_decls = flattenCAFSets tops
us <- mkSplitUniqSupply 'u'
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) (_, decl) =
return (topSRT, decl : rst)
{- Note [reverse gs]
It is important to keep the code blocks in the same order,
otherwise binary sizes get slightly bigger. I'm not completely
sure why this is, perhaps the assembler generates bigger jump
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
compiler/cmm/CmmLayoutStack.hs
View file @ 322044b2
......@@ -3,7 +3,7 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap, cmmSink
cmmLayoutStack, setInfoTableStackMap
) where
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX
......@@ -34,7 +34,7 @@ import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub, partition)
import Data.List (nub)
import Control.Monad (liftM)
#include "HsVersions.h"
......@@ -111,20 +111,20 @@ cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
cmmLayoutStack procpoints entry_args
graph0@(CmmGraph { g_entry = entry })
= do
pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
-- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
(graph, liveness) <- removeDeadAssignments graph0
pprTrace "liveness" (ppr liveness) $ return ()
-- pprTrace "liveness" (ppr liveness) $ return ()
let blocks = postorderDfs graph
(final_stackmaps, final_high_sp, new_blocks) <-
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
layout procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- mapM lowerSafeForeignCall new_blocks
pprTrace ("Sp HWM") (ppr final_high_sp) $
return (ofBlockList entry new_blocks', final_stackmaps)
-- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
return (ofBlockList entry new_blocks', final_stackmaps)
......@@ -167,7 +167,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
(pprPanic "no stack map for" (ppr entry_lbl))
entry_lbl acc_stackmaps
pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
-- pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
-- (a) Update the stack map to include the effects of
-- assignments in this block
......@@ -188,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
<- handleLastNode procpoints liveness cont_info
acc_stackmaps stack1 middle0 last0
pprTrace "layout(out)" (ppr out) $ return ()
-- pprTrace "layout(out)" (ppr out) $ return ()
-- (d) Manifest Sp: run over the nodes in the block and replace
-- CmmStackSlot with CmmLoad from Sp with a concrete offset.
......@@ -416,8 +416,8 @@ handleLastNode procpoints liveness cont_info stackmaps
case mapLookup l stackmaps of
Just pp_sm -> (pp_sm, fixupStack stack0 pp_sm)
Nothing ->
pprTrace "first visit to proc point"
(ppr l <+> ppr stack1) $
--pprTrace "first visit to proc point"
-- (ppr l <+> ppr stack1) $
(stack1, assigs)
where
cont_args = mapFindWithDefault 0 l cont_info
......@@ -570,7 +570,7 @@ allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O])
allocate ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
=
pprTrace "allocate" (ppr live $$ ppr stackmap) $
-- pprTrace "allocate" (ppr live $$ ppr stackmap) $
-- we only have to save regs that are not already in a slot
let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
......@@ -798,7 +798,8 @@ elimStackStores stackmap stackmaps area_off nodes
CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
| Just (_,off) <- lookupUFM (sm_regs stackmap) r
, area_off area + m == off
-> pprTrace "eliminated a node!" (ppr r) $ go stackmap ns
-> -- pprTrace "eliminated a node!" (ppr r) $
go stackmap ns
_otherwise
-> n : go (procMiddle stackmaps n stackmap) ns
......@@ -978,75 +979,3 @@ insertReloads stackmap =
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs sm = eltsUFM (sm_regs sm)
-- -----------------------------------------------------------------------------
-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
--
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
cmmSink :: CmmGraph -> UniqSM CmmGraph
cmmSink graph = do
let liveness = cmmLiveness graph
return $ cmmSink' liveness graph
cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph
cmmSink' liveness graph
= ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph
where
sink :: BlockEnv [(LocalReg, CmmExpr)] -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
sink sunk (b:bs) =
pprTrace "sink" (ppr l) $
blockJoin first final_middle last : sink sunk' bs
where
l = entryLabel b
(first, middle, last) = blockSplit b
(middle', assigs) = walk (blockToList middle) emptyBlock
(mapFindWithDefault [] l sunk)
(dropped_last, assigs') = partition (`conflictsWithLast` last) assigs
final_middle = foldl blockSnoc middle' (toNodes dropped_last)
sunk' = mapUnion sunk $
mapFromList [ (l, filt assigs' (getLive l))
| l <- successors last ]
where
getLive l = mapFindWithDefault Set.empty l liveness
filt as live = [ (r,e) | (r,e) <- as, r `Set.member` live ]
walk :: [CmmNode O O] -> Block CmmNode O O -> [(LocalReg, CmmExpr)]
-> (Block CmmNode O O, [(LocalReg, CmmExpr)])
walk [] acc as = (acc, as)
walk (n:ns) acc as
| Just a <- collect_it = walk ns acc (a:as)
| otherwise = walk ns (foldr (flip blockSnoc) acc (n:drop_nodes)) as'
where
collect_it = case n of
CmmAssign (CmmLocal r) e@(CmmReg (CmmGlobal _)) -> Just (r,e)
-- CmmAssign (CmmLocal r) e@(CmmLoad addr _) |
-- foldRegsUsed (\b r -> False) True addr -> Just (r,e)
_ -> Nothing
drop_nodes = toNodes dropped
(dropped, as') = partition should_drop as
where should_drop a = a `conflicts` n
toNodes :: [(LocalReg,CmmExpr)] -> [CmmNode O O]
toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
-- We only sink "r = G" assignments right now, so conflicts is very simple:
conflicts :: (LocalReg,CmmExpr) -> CmmNode O O -> Bool
(_, rhs) `conflicts` CmmAssign reg _ | reg `regUsedIn` rhs = True
--(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
(r, _) `conflicts` node
= foldRegsUsed (\b r' -> r == r' || b) False node
conflictsWithLast :: (LocalReg,CmmExpr) -> CmmNode O C -> Bool
(r, _) `conflictsWithLast` node
= foldRegsUsed (\b r' -> r == r' || b) False node
compiler/cmm/CmmPipeline.hs
View file @ 322044b2
......@@ -9,7 +9,6 @@ module CmmPipeline (
cmmPipeline
) where
import CLabel
import Cmm
import CmmLint
import CmmBuildInfoTables
......@@ -17,76 +16,42 @@ import CmmCommonBlockElim
import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
import CmmSink
import Hoopl
import UniqSupply
import DynFlags
import ErrUtils
import HscTypes
import Data.Maybe
import Control.Monad
import Outputable
import qualified Data.Set as Set
import Data.Map (Map)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
-----------------------------------------------------------------------------
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
-- an analysis of the procedures to tell us what CAFs they use.
-- The first stage returns a map from procedure labels to CAFs,
-- along with a closure that will compute SRTs and attach them to
-- the compiled procedures.
-- The second stage is to combine the CAF information into a top-level
-- CAF environment mapping non-static closures to the CAFs they keep live,
-- then pass that environment to the closures returned in the first
-- stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
-- are computed for each procedure.
-- The SRT needs to be threaded because it is grown lazily.
-- 3. We run control flow optimizations twice, once before any pipeline
-- work is done, and once again at the very end on all of the
-- resulting C-- blocks. EZY: It's unclear whether or not whether
-- we actually need to do the initial pass.
cmmPipeline :: HscEnv -- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
-> TopSRT -- SRT table and accumulating list of compiled procs
-> CmmGroup -- Input C-- with Procedures
-> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env topSRT prog =
do let dflags = hsc_dflags hsc_env
--
showPass dflags "CPSZ"
(cafEnvs, tops) <- {-# SCC "tops" #-} liftM unzip $ mapM (cpsTop hsc_env) prog
-- tops :: [[(CmmDecl,CAFSet]] (one list per group)
let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
-- folding over the groups
(topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops topCAFEnv) (topSRT, []) tops
showPass dflags "CPSZ"
let cmms :: CmmGroup
cmms = reverse (concat tops)
tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
(topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
return (topSRT, cmms)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
-- EZY: It might be helpful to have an easy way of dumping the "pre"
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz
cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
----------- Control-flow optimisations ---------------
......@@ -110,8 +75,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
runUniqSM $ cmmLayoutStack procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
-- g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
-- dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
g <- if optLevel dflags >= 99
then do g <- {-# SCC "sink" #-} return (cmmSink g)
dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
return g
else return g
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
......@@ -126,31 +96,21 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- More CAFs ------------------------------
------------- CAF analysis ------------------------------
let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
------------- Populate info tables with stack info ------
gs <- {-# SCC "setInfoTableStackMap" #-}
return $ map (setInfoTableStackMap stackmaps) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations ---------------
----------- Control-flow optimisations -----------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
return (localCAFs, gs)
-- gs :: [ (CAFSet, CmmDecl) ]
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
return (cafEnv, gs)
where dflags = hsc_dflags hsc_env
mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
| otherwise = z
dump = dumpGraph dflags
dumps flag name
......@@ -182,14 +142,3 @@ dumpWith dflags flag txt g = do
when (not (dopt flag dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
-> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
return (topSRT, concat gs' : tops)
compiler/cmm/CmmSink.hs 0 → 100644
View file @ 322044b2
{-# LANGUAGE GADTs #-}
module CmmSink (
cmmSink,
cmmPeepholeInline
) where
import Cmm
import BlockId
import CmmLive
import CmmUtils
import Hoopl
import UniqFM
import Unique
import Outputable
import qualified Data.Set as Set
-- -----------------------------------------------------------------------------
-- Sinking
-- This is an optimisation pass that
-- (a) moves assignments closer to their uses, to reduce register pressure
-- (b) pushes assignments into a single branch of a conditional if possible
-- It is particularly helpful in the Cmm generated by the Stg->Cmm
-- code generator, in which every function starts with a copyIn
-- sequence like:
--