summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs4
-rw-r--r--compiler/cmm/CmmCPS.hs1
-rw-r--r--compiler/cmm/CmmCPSZ.hs7
-rw-r--r--compiler/cmm/CmmSpillReload.hs3
-rw-r--r--compiler/cmm/CmmStackLayout.hs4
-rw-r--r--compiler/cmm/ZipCfg.hs17
-rw-r--r--compiler/cmm/ZipCfgCmmRep.hs3
-rw-r--r--compiler/cmm/ZipDataflow.hs23
8 files changed, 53 insertions, 9 deletions
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 2cadd8df69..c4a16d359e 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmBuildInfoTables
( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index c5bcdc3215..17c11ce264 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -235,6 +235,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
start_block = lookupWithDefaultBEnv blocks unknown_block start
children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
+ unknown_block :: a -- Used at more than one type
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
body = start_block : children_blocks
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 8bcadbb122..e72d3f2da9 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
@@ -153,7 +157,10 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+
+ run :: FuelMonad a -> IO a
run = runFuelIO (hsc_OptFuel hsc_env)
+
dual_rewrite flag txt pass g =
do dump flag ("Pre " ++ txt) g
g <- run $ pass g
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index df05a654f8..c457383e6b 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
module CmmSpillReload
( DualLive(..)
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index d9cd411862..a62580b528 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
, layout, manifestSP, igraph, areaBuilder
diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index 376ab3ea52..1001f23b77 100644
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -461,25 +461,32 @@ postorder_dfs g@(LGraph _ blockenv) =
let FGraph id eblock _ = entry g in
zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
-postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
+postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l)
=> BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
-postorder_dfs_from_except blocks b visited =
- vchildren (get_children b) (\acc _visited -> acc) [] visited
+postorder_dfs_from_except blocks b visited
+ = vchildren (get_children b) (\acc _visited -> acc) [] visited
where
- -- vnode ::
- -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
+ vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
+ -> [Block m l] -> BlockSet -> a
vnode block@(Block id _) cont acc visited =
if elemBlockSet id visited then
cont acc visited
else
let cont' acc visited = cont (block:acc) visited in
vchildren (get_children block) cont' acc (extendBlockSet visited id)
+
+ vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
+ -> [Block m l] -> BlockSet -> a
vchildren bs cont acc visited =
let next children acc visited =
case children of [] -> cont acc visited
(b:bs) -> vnode b (next bs) acc visited
in next bs acc visited
+
+ get_children :: HavingSuccessors c => c -> [Block m l]
get_children block = foldl add_id [] (succs block)
+
+ add_id :: [Block m l] -> BlockId -> [Block m l]
add_id rst id = case lookupBlockEnv blocks id of
Just b -> b : rst
Nothing -> rst
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 0a494f853f..1377e2f67c 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+
-- This module is pure representation and should be imported only by
-- clients that need to manipulate representation and know what
-- they're doing. Clients that need to create flow graphs should
diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index ba8e75ac64..388d99cc95 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -528,8 +528,14 @@ forward_sol check_maybe = forw
; b <- finish
; return (b, fuel)
}
+
-- The need for both k1 and k2 suggests that maybe there's an opportunity
-- for improvement here -- in most cases, they're the same...
+ rec_rewrite :: forall t bI bW.
+ Maybe (AGraph m l) -> t -> DFM a bW
+ -> (t -> Fuel -> DFM a bI)
+ -> (bW -> Fuel -> DFM a bI)
+ -> a -> Fuel -> DFM a bI
rec_rewrite rewritten analyzed finish k1 k2 in' fuel =
case check_maybe fuel rewritten of -- fr_first rewrites id idfact of
Nothing -> k1 analyzed fuel
@@ -589,7 +595,6 @@ forward_rew
-> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
forward_rew check_maybe = forw
where
- solve = forward_sol check_maybe
forw :: RewritingDepth
-> BlockEnv a
-> PassName
@@ -607,7 +612,8 @@ forward_rew check_maybe = forw
in_fact `seq` g `seq`
let Graph entry blockenv = g
blocks = G.postorder_dfs_from blockenv entry
- in do { _ <- solve depth name start transfers rewrites in_fact g fuel
+ in do { _ <- forward_sol check_maybe depth name start
+ transfers rewrites in_fact g fuel
; eid <- freshBlockId "temporary entry id"
; (rewritten, fuel) <-
rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
@@ -615,11 +621,18 @@ forward_rew check_maybe = forw
; a <- finish
; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
}
+
+ don't_rewrite :: forall t.
+ BlockEnv a -> DFM a t -> a
+ -> Graph m l -> Fuel
+ -> DFM a (t, Graph m l, Fuel)
don't_rewrite facts finish in_fact g fuel =
- do { _ <- solve depth name facts transfers rewrites in_fact g fuel
+ do { _ <- forward_sol check_maybe depth name facts
+ transfers rewrites in_fact g fuel
; a <- finish
; return (a, g, fuel)
}
+
inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
where inner_rew' = case depth of RewriteShallow -> don't_rewrite
@@ -633,6 +646,7 @@ forward_rew check_maybe = forw
; let fp = FFP cfp last_outs
; return (fp, fuel)
}
+
-- JD: WHY AREN'T WE TAKING ANY FUEL HERE?
rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
-> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
@@ -1028,8 +1042,9 @@ run dir name do_block blocks b =
pprFacts depth n env =
my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
(nest 2 $ vcat $ map pprFact $ blockEnvToList env))
- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
+pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc
+pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
View Lorry Controller Status