Commit ba60dc74 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

minor changes to Cmm left over from September 2007

Nothing too deep here; primarily tinking with prettyprinting
and names.  Also eliminated some warnings.  This patch covers
most (but not all) of the code NR changed at the very end
of September 2007, just before ICFP hit...
parent ad5299d9
module CmmCPSZ ( module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters -- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest. -- to a CPS transformed C-- with the stack made manifest.
...@@ -31,6 +30,9 @@ protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm ...@@ -31,6 +30,9 @@ protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
-> CmmZ -- ^ Input C-- with Proceedures -> CmmZ -- ^ Input C-- with Proceedures
-> IO CmmZ -- ^ Output CPS transformed C-- -> IO CmmZ -- ^ Output CPS transformed C--
protoCmmCPSZ dflags (Cmm tops) protoCmmCPSZ dflags (Cmm tops)
| not (dopt Opt_RunCPSZ dflags)
= return (Cmm tops) -- Only if -frun-cps
| otherwise
= do { showPass dflags "CPSZ" = do { showPass dflags "CPSZ"
; u <- mkSplitUniqSupply 'p' ; u <- mkSplitUniqSupply 'p'
; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel] ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
...@@ -58,13 +60,17 @@ cpsTop (CmmProc h l args g) = ...@@ -58,13 +60,17 @@ cpsTop (CmmProc h l args g) =
let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g) let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
g' = addProcPointProtocols procPoints args g g' = addProcPointProtocols procPoints args g
g'' = map_nodes id NotSpillOrReload id g' g'' = map_nodes id NotSpillOrReload id g'
-- Change types of middle nodes to allow spill/reload
in do { u1 <- getUs; u2 <- getUs; u3 <- getUs in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
; entry <- getUniqueUs >>= return . BlockId ; entry <- getUniqueUs >>= return . BlockId
; return $ ; return $
do { g <- return g'' do { g <- return g''
; g <- dual_rewrite u1 dualLivenessWithInsertion g ; g <- dual_rewrite u1 dualLivenessWithInsertion g
-- Insert spills at defns; reloads at return points
; g <- insertLateReloads' u2 (extend g) ; g <- insertLateReloads' u2 (extend g)
-- Duplicate reloads just before uses
; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g) ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
-- Remove redundant reloads (and any other redundant asst)
; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
} }
} }
......
...@@ -41,7 +41,7 @@ type BlockEntryLiveness = BlockEnv CmmLive ...@@ -41,7 +41,7 @@ type BlockEntryLiveness = BlockEnv CmmLive
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> BlockEntryLiveness cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
cmmLivenessZ g = env cmmLivenessZ g = env
where env = runDFA liveLattice $ do { run_b_anal transfer g; allFacts } where env = runDFA liveLattice $ do { run_b_anal transfer g; getAllFacts }
transfer = BComp "liveness analysis" exit last middle first transfer = BComp "liveness analysis" exit last middle first
exit = emptyUniqSet exit = emptyUniqSet
first live _ = live first live _ = live
......
...@@ -132,7 +132,7 @@ extendPPSet g blocks procPoints = ...@@ -132,7 +132,7 @@ extendPPSet g blocks procPoints =
Nothing -> procPoints' Nothing -> procPoints'
where env = runDFA lattice $ where env = runDFA lattice $
do refine_f_anal forward g set_init_points do refine_f_anal forward g set_init_points
allFacts getAllFacts
set_init_points = mapM_ (\id -> setFact id ProcPoint) set_init_points = mapM_ (\id -> setFact id ProcPoint)
(uniqSetToList procPoints) (uniqSetToList procPoints)
procPoints' = fold_blocks add emptyBlockSet g procPoints' = fold_blocks add emptyBlockSet g
......
...@@ -205,7 +205,8 @@ data AvailRegs = UniverseMinus RegSet ...@@ -205,7 +205,8 @@ data AvailRegs = UniverseMinus RegSet
availRegsLattice :: DataflowLattice AvailRegs availRegsLattice :: DataflowLattice AvailRegs
availRegsLattice = DataflowLattice "register gotten from reloads" empty add True availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
-- last True <==> debugging on
where empty = UniverseMinus emptyRegSet where empty = UniverseMinus emptyRegSet
-- | compute in the Tx monad to track whether anything has changed -- | compute in the Tx monad to track whether anything has changed
add new old = add new old =
...@@ -241,7 +242,7 @@ cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs ...@@ -241,7 +242,7 @@ cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
cmmAvailableReloads g = env cmmAvailableReloads g = env
where env = runDFA availRegsLattice $ where env = runDFA availRegsLattice $
do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
allFacts getAllFacts
avail_reloads_transfer :: FAnalysis M Last AvailRegs avail_reloads_transfer :: FAnalysis M Last AvailRegs
avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
......
...@@ -128,6 +128,7 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off] ...@@ -128,6 +128,7 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off]
-- a later optimisation step on Cmm). -- a later optimisation step on Cmm).
-- --
cmmOffset :: CmmExpr -> Int -> CmmExpr cmmOffset :: CmmExpr -> Int -> CmmExpr
cmmOffset e 0 = e
cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off
cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
......
...@@ -3,13 +3,13 @@ module DFMonad ...@@ -3,13 +3,13 @@ module DFMonad
( DataflowLattice(..) ( DataflowLattice(..)
, DataflowAnalysis , DataflowAnalysis
, markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
, forgetFact, botFact, allFacts, factsEnv, checkFactMatch , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv, checkFactMatch
, addLastOutFact, bareLastOutFacts, forgetLastOutFacts , addLastOutFact, bareLastOutFacts, forgetLastOutFacts
, subAnalysis , subAnalysis
, DFA, runDFA , DFA, runDFA
, DFM, runDFM, liftAnal , DFM, runDFM, liftAnal
, markGraphRewritten , markGraphRewritten, graphWasRewritten
, freshBlockId , freshBlockId
, liftUSM , liftUSM
, module OptimizationFuel , module OptimizationFuel
...@@ -123,11 +123,12 @@ class DataflowAnalysis m where ...@@ -123,11 +123,12 @@ class DataflowAnalysis m where
addLastOutFact :: (BlockId, f) -> m f () addLastOutFact :: (BlockId, f) -> m f ()
bareLastOutFacts :: m f [(BlockId, f)] bareLastOutFacts :: m f [(BlockId, f)]
forgetLastOutFacts :: m f () forgetLastOutFacts :: m f ()
allFacts :: m f (BlockEnv f) getAllFacts :: m f (BlockEnv f)
setAllFacts :: BlockEnv f -> m f ()
factsEnv :: Monad (m f) => m f (BlockId -> f) factsEnv :: Monad (m f) => m f (BlockId -> f)
lattice :: m f (DataflowLattice f) lattice :: m f (DataflowLattice f)
factsEnv = do { map <- allFacts factsEnv = do { map <- getAllFacts
; bot <- botFact ; bot <- botFact
; return $ \id -> lookupBlockEnv map id `orElse` bot } ; return $ \id -> lookupBlockEnv map id `orElse` bot }
...@@ -163,6 +164,10 @@ instance DataflowAnalysis DFA where ...@@ -163,6 +164,10 @@ instance DataflowAnalysis DFA where
let debug = if log then pprTrace else \_ _ a -> a let debug = if log then pprTrace else \_ _ a -> a
in debug name (pprSetFact "exit" old a join) $ in debug name (pprSetFact "exit" old a join) $
((), s { df_exit_fact = join, df_facts_change = SomeChange }) ((), s { df_exit_fact = join, df_facts_change = SomeChange })
getAllFacts = DFA f
where f _ s = (df_facts s, s)
setAllFacts env = DFA f
where f _ s = ((), s { df_facts = env})
botFact = DFA f botFact = DFA f
where f lattice s = (fact_bot lattice, s) where f lattice s = (fact_bot lattice, s)
forgetFact id = DFA f forgetFact id = DFA f
...@@ -173,15 +178,13 @@ instance DataflowAnalysis DFA where ...@@ -173,15 +178,13 @@ instance DataflowAnalysis DFA where
where f _ s = (df_last_outs s, s) where f _ s = (df_last_outs s, s)
forgetLastOutFacts = DFA f forgetLastOutFacts = DFA f
where f _ s = ((), s { df_last_outs = [] }) where f _ s = ((), s { df_last_outs = [] })
allFacts = DFA f
where f _ s = (df_facts s, s)
checkFactMatch id a = checkFactMatch id a =
do { fact <- lattice do { fact <- lattice
; old_a <- getFact id ; old_a <- getFact id
; case fact_add_to fact a old_a of ; case fact_add_to fact a old_a of
TxRes NoChange _ -> return () TxRes NoChange _ -> return ()
TxRes SomeChange new -> TxRes SomeChange new ->
do { facts <- allFacts do { facts <- getAllFacts
; pprPanic "checkFactMatch" ; pprPanic "checkFactMatch"
(f4sep [text (fact_name fact), text "at id" <+> ppr id, (f4sep [text (fact_name fact), text "at id" <+> ppr id,
text "changed from", nest 4 (ppr old_a), text "to", text "changed from", nest 4 (ppr old_a), text "to",
...@@ -213,7 +216,8 @@ instance DataflowAnalysis DFM where ...@@ -213,7 +216,8 @@ instance DataflowAnalysis DFM where
addLastOutFact p = liftAnal $ addLastOutFact p addLastOutFact p = liftAnal $ addLastOutFact p
bareLastOutFacts = liftAnal $ bareLastOutFacts bareLastOutFacts = liftAnal $ bareLastOutFacts
forgetLastOutFacts = liftAnal $ forgetLastOutFacts forgetLastOutFacts = liftAnal $ forgetLastOutFacts
allFacts = liftAnal $ allFacts getAllFacts = liftAnal $ getAllFacts
setAllFacts env = liftAnal $ setAllFacts env
checkFactMatch id a = liftAnal $ checkFactMatch id a checkFactMatch id a = liftAnal $ checkFactMatch id a
lattice = liftAnal $ lattice lattice = liftAnal $ lattice
...@@ -229,6 +233,10 @@ markGraphRewritten :: DFM f () ...@@ -229,6 +233,10 @@ markGraphRewritten :: DFM f ()
markGraphRewritten = DFM f markGraphRewritten = DFM f
where f _ s = ((), s {df_rewritten = SomeChange}) where f _ s = ((), s {df_rewritten = SomeChange})
graphWasRewritten :: DFM f ChangeFlag
graphWasRewritten = DFM f
where f _ s = (df_rewritten s, s)
freshBlockId :: String -> DFM f BlockId freshBlockId :: String -> DFM f BlockId
freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
......
...@@ -7,6 +7,7 @@ module OptimizationFuel ...@@ -7,6 +7,7 @@ module OptimizationFuel
, lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
, fuelDecrementState , fuelDecrementState
, runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
, runWithInfiniteFuel
, FuelMonad(..) , FuelMonad(..)
) )
where where
...@@ -59,6 +60,8 @@ fuelConsumingPass name f = do fuel <- fuelRemaining ...@@ -59,6 +60,8 @@ fuelConsumingPass name f = do fuel <- fuelRemaining
runFuel :: FuelMonad a -> FuelConsumer a runFuel :: FuelMonad a -> FuelConsumer a
runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String) runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
runWithInfiniteFuel :: FuelMonad a -> a
runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
runFuelIO pass_ref fuel_ref (FuelMonad f) = runFuelIO pass_ref fuel_ref (FuelMonad f) =
...@@ -78,6 +81,8 @@ runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel ...@@ -78,6 +81,8 @@ runFuel (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
in ((a, fs_lastpass s), fs_fuellimit s) in ((a, fs_lastpass s), fs_fuellimit s)
runWithInfiniteFuel (FuelMonad f) = fst $ f $ initialFuelState $ tankFilledTo maxBound
lastFuelPassInState :: FuelState -> String lastFuelPassInState :: FuelState -> String
lastFuelPassInState = fs_lastpass lastFuelPassInState = fs_lastpass
......
...@@ -34,6 +34,7 @@ module PprC ( ...@@ -34,6 +34,7 @@ module PprC (
-- Cmm stuff -- Cmm stuff
import Cmm import Cmm
import PprCmm () -- Instances only
import CLabel import CLabel
import MachOp import MachOp
import ForeignCall import ForeignCall
......
{-# 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/Commentary/CodingStyle#Warnings
-- for details
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
-- --
-- Pretty-printing of Cmm as (a superset of) C-- -- Pretty-printing of Cmm as (a superset of) C--
...@@ -92,6 +85,9 @@ instance Outputable CmmExpr where ...@@ -92,6 +85,9 @@ instance Outputable CmmExpr where
instance Outputable CmmReg where instance Outputable CmmReg where
ppr e = pprReg e ppr e = pprReg e
instance Outputable CmmLit where
ppr l = pprLit l
instance Outputable LocalReg where instance Outputable LocalReg where
ppr e = pprLocalReg e ppr e = pprLocalReg e
...@@ -145,12 +141,13 @@ instance Outputable CmmSafety where ...@@ -145,12 +141,13 @@ instance Outputable CmmSafety where
-- For ideas on how to refine it, they used to be printed in the -- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body, -- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info". -- and were labelled with the procedure name ++ "_info".
pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) = pprInfo :: CmmInfo -> SDoc
pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
vcat [{-ptext (sLit "gc_target: ") <> vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) pprBlockId gc_target,-} maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
ptext (sLit "update_frame: ") <> ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame] maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
pprInfo (CmmInfo gc_target update_frame pprInfo (CmmInfo _gc_target update_frame
(CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) = (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
vcat [{-ptext (sLit "gc_target: ") <> vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) pprBlockId gc_target,-} maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
...@@ -161,12 +158,13 @@ pprInfo (CmmInfo gc_target update_frame ...@@ -161,12 +158,13 @@ pprInfo (CmmInfo gc_target update_frame
ptext (sLit "tag: ") <> integer (toInteger tag), ptext (sLit "tag: ") <> integer (toInteger tag),
pprTypeInfo info] pprTypeInfo info]
pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (ConstrInfo layout constr descr) = pprTypeInfo (ConstrInfo layout constr descr) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "constructor: ") <> integer (toInteger constr), ptext (sLit "constructor: ") <> integer (toInteger constr),
pprLit descr] pprLit descr]
pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) = pprTypeInfo (FunInfo layout srt fun_type arity _args slow_entry) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "srt: ") <> ppr srt, ptext (sLit "srt: ") <> ppr srt,
...@@ -241,8 +239,22 @@ pprStmt stmt = case stmt of ...@@ -241,8 +239,22 @@ pprStmt stmt = case stmt of
CmmNeverReturns -> ptext (sLit " never returns"), CmmNeverReturns -> ptext (sLit " never returns"),
semi ] semi ]
where where
target (CmmLit lit) = pprLit lit ---- With the following three functions, I was going somewhere
target fn' = parens (ppr fn') ---- useful, but I don't remember where. Probably making
---- emitted Cmm output look better. ---NR, 2 May 2008
_pp_lhs | null results = empty
| otherwise = commafy (map ppr_ar results) <+> equals
-- Don't print the hints on a native C-- call
ppr_ar arg = case cconv of
CmmCallConv -> ppr (hintlessCmm arg)
_ -> doubleQuotes (ppr $ cmmHint arg) <+>
ppr (hintlessCmm arg)
_pp_conv = case cconv of
CmmCallConv -> empty
_ -> ptext (sLit "foreign") <+> doubleQuotes (ppr cconv)
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
CmmCall (CmmPrim op) results args safety ret -> CmmCall (CmmPrim op) results args safety ret ->
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
...@@ -341,7 +353,7 @@ genSwitch expr maybe_ids ...@@ -341,7 +353,7 @@ genSwitch expr maybe_ids
snds a b = (snd a) == (snd b) snds a b = (snd a) == (snd b)
caseify :: [(Int,Maybe BlockId)] -> SDoc caseify :: [(Int,Maybe BlockId)] -> SDoc
caseify ixs@((i,Nothing):_) caseify ixs@((_,Nothing):_)
= ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
<> ptext (sLit " */") <> ptext (sLit " */")
caseify as caseify as
...@@ -379,10 +391,13 @@ pprExpr e ...@@ -379,10 +391,13 @@ pprExpr e
-- a default conservative behaviour. -- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '==' -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
= pprExpr7 x <+> doc <+> pprExpr7 y = pprExpr7 x <+> doc <+> pprExpr7 y
pprExpr1 e = pprExpr7 e pprExpr1 e = pprExpr7 e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
...@@ -479,8 +494,9 @@ pprLit lit = case lit of ...@@ -479,8 +494,9 @@ pprLit lit = case lit of
CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-' CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
<> pprCLabel clbl2 <> ppr_offset i <> pprCLabel clbl2 <> ppr_offset i
pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit) pprLit1 :: CmmLit -> SDoc
pprLit1 lit = pprLit lit pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
pprLit1 lit = pprLit lit
ppr_offset :: Int -> SDoc ppr_offset :: Int -> SDoc
ppr_offset i ppr_offset i
...@@ -569,4 +585,4 @@ pprBlockId b = ppr $ getUnique b ...@@ -569,4 +585,4 @@ pprBlockId b = ppr $ getUnique b
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
commafy :: [SDoc] -> SDoc commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs commafy xs = fsep $ punctuate comma xs
...@@ -23,7 +23,7 @@ type M = ExtendWithSpills Middle ...@@ -23,7 +23,7 @@ type M = ExtendWithSpills Middle
foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a
foldConflicts f z g = foldConflicts f z g =
let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> allFacts) let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
f' dual z = f (on_stack dual) z f' dual z = f (on_stack dual) z
in fold_edge_facts_b f' dualLiveness g lookup z in fold_edge_facts_b f' dualLiveness g lookup z
......
...@@ -691,10 +691,16 @@ instance (Outputable m, Outputable l) => Outputable (ZTail m l) where ...@@ -691,10 +691,16 @@ instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
ppr = pprLgraph ppr = pprLgraph
instance (Outputable l) => Outputable (ZLast l) where
ppr = pprLast
pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
pprTail (ZTail m t) = ppr m $$ ppr t pprTail (ZTail m t) = ppr m $$ ppr t
pprTail (ZLast LastExit) = text "<exit>" pprTail (ZLast l) = ppr l
pprTail (ZLast (LastOther l)) = ppr l
pprLast :: (Outputable l) => ZLast l -> SDoc
pprLast LastExit = text "<exit>"
pprLast (LastOther l) = ppr l
pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}" pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
......
...@@ -8,26 +8,33 @@ ...@@ -8,26 +8,33 @@
module ZipCfgCmmRep module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..) ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
, ValueDirection(..) , ValueDirection(..)
, pprCmmGraphLikeCmm
) )
where where
import CmmExpr import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..) , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..)
, CmmStmt(CmmSwitch) -- imported in order to call ppr , CmmStmt(..) -- imported in order to call ppr on Switch and to
-- implement pprCmmGraphLikeCmm
, CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
, CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm
) )
import PprCmm() import PprCmm()
import CLabel import CLabel
import CmmZipUtil
import ClosureInfo import ClosureInfo
import FastString import FastString
import ForeignCall import ForeignCall
import MachOp import MachOp
import qualified ZipCfg as Z
import qualified ZipDataflow0 as DF import qualified ZipDataflow0 as DF
import ZipCfg import ZipCfg
import MkZipCfg import MkZipCfg
import Util import Util
import UniqSet
import Maybes import Maybes
import Outputable import Outputable
import Prelude hiding (zip, unzip, last) import Prelude hiding (zip, unzip, last)
...@@ -200,7 +207,9 @@ debugPpr :: Bool ...@@ -200,7 +207,9 @@ debugPpr :: Bool
debugPpr = debugIsOn debugPpr = debugIsOn
pprMiddle :: Middle -> SDoc pprMiddle :: Middle -> SDoc
pprMiddle stmt = (case stmt of pprMiddle stmt = pp_stmt <+> pp_debug
where
pp_stmt = case stmt of
CopyIn conv args _ -> CopyIn conv args _ ->
if null args then ptext (sLit "empty CopyIn") if null args then ptext (sLit "empty CopyIn")
...@@ -243,17 +252,17 @@ pprMiddle stmt = (case stmt of ...@@ -243,17 +252,17 @@ pprMiddle stmt = (case stmt of
hcat [ ptext (sLit "return via ") hcat [ ptext (sLit "return via ")
, ppr_target ra, parens (commafy $ map ppr args), semi ] , ppr_target ra, parens (commafy $ map ppr args), semi ]
) <> pp_debug =
if debugPpr then empty if not debugPpr then empty
else text " //" <+> else text " //" <+>
case stmt of case stmt of
CopyIn {} -> text "CopyIn" CopyIn {} -> text "CopyIn"
CopyOut {} -> text "CopyOut" CopyOut {} -> text "CopyOut"
MidComment {} -> text "MidComment" MidComment {} -> text "MidComment"
MidAssign {} -> text "MidAssign" MidAssign {} -> text "MidAssign"
MidStore {} -> text "MidStore" MidStore {} -> text "MidStore"
MidUnsafeCall {} -> text "MidUnsafeCall" MidUnsafeCall {} -> text "MidUnsafeCall"
MidAddToContext {} -> text "MidAddToContext" MidAddToContext {} -> text "MidAddToContext"
ppr_target :: CmmExpr -> SDoc ppr_target :: CmmExpr -> SDoc
...@@ -317,3 +326,114 @@ pprConvention (ConventionPrivate {} ) = text "<private-convention>" ...@@ -317,3 +326,114 @@ pprConvention (ConventionPrivate {} ) = text "<private-convention>"
commafy :: [SDoc] -> SDoc commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs commafy xs = hsep $ punctuate comma xs
----------------------------------------------------------------
-- | The purpose of this function is to print a Cmm zipper graph "as if it were"
-- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
-- code are dodgy as well.
pprCmmGraphLikeCmm :: CmmGraph -> SDoc
pprCmmGraphLikeCmm g = vcat (swallow blocks)
where blocks = Z.postorder_dfs g
swallow :: [CmmBlock] -> [SDoc]
swallow [] = []
swallow (Z.Block id t : rest) = tail id [] Nothing t rest
tail id prev' out (Z.ZTail (CopyOut conv args) t) rest =
if isJust out then panic "multiple CopyOut nodes in one basic block"
else
tail id (prev') (Just (conv, args)) t rest
tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
tail id prev' out (Z.ZLast Z.LastExit) rest = exit id prev' out rest
tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
mid (CopyIn _ [] _) = text "// proc point (no parameters)"
mid m@(CopyIn {}) = ppr m <+> text "(proc point)"
mid m = ppr m
block' id prev'
| id == Z.lg_entry g, entry_has_no_pred =
vcat (text "<entry>" : reverse prev')
| otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
LastBranch tgt ->
case n of
Z.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' out t bs -- optimize out redundant labels
_ -> endblock (ppr $ CmmBranch tgt)
l@(LastCondBranch expr tid fid) ->
let ft id = text "// fall through to " <> ppr id in
case n of
Z.Block id' t : bs
| id' == fid, isNothing out ->
tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
| id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
_ -> endblock $ with_out out l
l@(LastJump {}) -> endblock $ with_out out l
l@(LastReturn {}) -> endblock $ with_out out l
l@(LastSwitch {}) -> endblock $ with_out out l
l@(LastCall _ Nothing) -> endblock $ with_out out l
l@(LastCall tgt (Just k))
| Z.Block id' (Z.ZTail (CopyIn _ ress srt) t) : bs <- n,
Just (conv, args) <- out,
id' == k ->
let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
tgt' = CmmCallee tgt (cconv_of_conv conv)
ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
in if unique_pred k then
tail id (ppcall : prev') Nothing t bs
else
endblock (ppcall)
| Z.Block id' t : bs <- n, id' == k, unique_pred k,
Just (conv, args) <- out,
Just (ress, srt) <- findCopyIn t ->
let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
tgt' = CmmCallee tgt (cconv_of_conv conv)
delayed =
ptext (sLit "// delayed CopyIn follows previous call")
in tail id (delayed : ppr call : prev') Nothing t bs
| otherwise -> endblock $ with_out out l
findCopyIn (Z.ZTail (CopyIn _ ress srt) _) = Just (ress, srt)
findCopyIn (Z.ZTail _ t) = findCopyIn t
findCopyIn (Z.ZLast _) = Nothing
exit id prev' out n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case out of Nothing -> endblock (text "// <exit>")
Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
text "// <exit>")
preds = zipPreds g
entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
Nothing -> True
Just s -> isEmptyUniqSet s
single_preds =
let add b single =
let id = Z.blockId b
in case Z.lookupBlockEnv preds id of
Nothing -> single
Just s -> if sizeUniqSet s == 1 then
Z.extendBlockSet single id
else single
in Z.fold_blocks add Z.emptyBlockSet g
unique_pred id = Z.elemBlockSet id single_preds
cconv_of_conv (ConventionStandard conv _) = conv
cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus