-
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
-> CmmZ -- ^ Input C-- with Proceedures
-> IO CmmZ -- ^ Output CPS transformed C--
protoCmmCPSZ dflags (Cmm tops)
+ | not (dopt Opt_RunCPSZ dflags)
+ = return (Cmm tops) -- Only if -frun-cps
+ | otherwise
= do { showPass dflags "CPSZ"
; u <- mkSplitUniqSupply 'p'
; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
g' = addProcPointProtocols procPoints args 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
; entry <- getUniqueUs >>= return . BlockId
; return $
do { g <- return g''
; g <- dual_rewrite u1 dualLivenessWithInsertion g
+ -- Insert spills at defns; reloads at return points
; g <- insertLateReloads' u2 (extend g)
+ -- Duplicate reloads just before uses
; 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
}
}
-----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
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
exit = emptyUniqSet
first live _ = live
Nothing -> procPoints'
where env = runDFA lattice $
do refine_f_anal forward g set_init_points
- allFacts
+ getAllFacts
set_init_points = mapM_ (\id -> setFact id ProcPoint)
(uniqSetToList procPoints)
procPoints' = fold_blocks add emptyBlockSet g
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
-- | compute in the Tx monad to track whether anything has changed
add new old =
cmmAvailableReloads g = env
where env = runDFA availRegsLattice $
do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
- allFacts
+ getAllFacts
avail_reloads_transfer :: FAnalysis M Last AvailRegs
avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
-- a later optimisation step on Cmm).
--
cmmOffset :: CmmExpr -> Int -> CmmExpr
+cmmOffset e 0 = e
cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off
cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
( DataflowLattice(..)
, DataflowAnalysis
, markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
- , forgetFact, botFact, allFacts, factsEnv, checkFactMatch
+ , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv, checkFactMatch
, addLastOutFact, bareLastOutFacts, forgetLastOutFacts
, subAnalysis
, DFA, runDFA
, DFM, runDFM, liftAnal
- , markGraphRewritten
+ , markGraphRewritten, graphWasRewritten
, freshBlockId
, liftUSM
, module OptimizationFuel
addLastOutFact :: (BlockId, f) -> m f ()
bareLastOutFacts :: m f [(BlockId, 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)
lattice :: m f (DataflowLattice f)
- factsEnv = do { map <- allFacts
+ factsEnv = do { map <- getAllFacts
; bot <- botFact
; return $ \id -> lookupBlockEnv map id `orElse` bot }
let debug = if log then pprTrace else \_ _ a -> a
in debug name (pprSetFact "exit" old a join) $
((), 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
where f lattice s = (fact_bot lattice, s)
forgetFact id = DFA f
where f _ s = (df_last_outs s, s)
forgetLastOutFacts = DFA f
where f _ s = ((), s { df_last_outs = [] })
- allFacts = DFA f
- where f _ s = (df_facts s, s)
checkFactMatch id a =
do { fact <- lattice
; old_a <- getFact id
; case fact_add_to fact a old_a of
TxRes NoChange _ -> return ()
TxRes SomeChange new ->
- do { facts <- allFacts
+ do { facts <- getAllFacts
; pprPanic "checkFactMatch"
(f4sep [text (fact_name fact), text "at id" <+> ppr id,
text "changed from", nest 4 (ppr old_a), text "to",
addLastOutFact p = liftAnal $ addLastOutFact p
bareLastOutFacts = liftAnal $ bareLastOutFacts
forgetLastOutFacts = liftAnal $ forgetLastOutFacts
- allFacts = liftAnal $ allFacts
+ getAllFacts = liftAnal $ getAllFacts
+ setAllFacts env = liftAnal $ setAllFacts env
checkFactMatch id a = liftAnal $ checkFactMatch id a
lattice = liftAnal $ lattice
markGraphRewritten = DFM f
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 _s = liftUSM $ getUniqueUs >>= return . BlockId
, lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
, fuelDecrementState
, runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
+ , runWithInfiniteFuel
, FuelMonad(..)
)
where
runFuel :: FuelMonad a -> FuelConsumer a
runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
+runWithInfiniteFuel :: FuelMonad a -> a
+
runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
runFuelIO pass_ref fuel_ref (FuelMonad f) =
runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
in ((a, fs_lastpass s), fs_fuellimit s)
+runWithInfiniteFuel (FuelMonad f) = fst $ f $ initialFuelState $ tankFilledTo maxBound
+
lastFuelPassInState :: FuelState -> String
lastFuelPassInState = fs_lastpass
-- Cmm stuff
import Cmm
+import PprCmm () -- Instances only
import CLabel
import MachOp
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--
instance Outputable CmmReg where
ppr e = pprReg e
+instance Outputable CmmLit where
+ ppr l = pprLit l
+
instance Outputable LocalReg where
ppr e = pprLocalReg e
-- 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,
-- 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: ") <>
maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
ptext (sLit "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)) =
vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
ptext (sLit "tag: ") <> integer (toInteger tag),
pprTypeInfo info]
+pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (ConstrInfo layout constr descr) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "constructor: ") <> integer (toInteger constr),
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)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "srt: ") <> ppr srt,
CmmNeverReturns -> ptext (sLit " never returns"),
semi ]
where
- target (CmmLit lit) = pprLit lit
- target fn' = parens (ppr fn')
+ ---- With the following three functions, I was going somewhere
+ ---- 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 ->
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
snds a b = (snd a) == (snd b)
caseify :: [(Int,Maybe BlockId)] -> SDoc
- caseify ixs@((i,Nothing):_)
+ caseify ixs@((_,Nothing):_)
= ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
<> ptext (sLit " */")
caseify as
-- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
= pprExpr7 x <+> doc <+> pprExpr7 y
pprExpr1 e = pprExpr7 e
+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
+
infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
<> pprCLabel clbl2 <> ppr_offset i
-pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
+pprLit1 lit = pprLit lit
ppr_offset :: Int -> SDoc
ppr_offset i
-----------------------------------------------------------------------------
commafy :: [SDoc] -> SDoc
-commafy xs = hsep $ punctuate comma xs
+commafy xs = fsep $ punctuate comma xs
foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a
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
f' dual z = f (on_stack dual) z
in fold_edge_facts_b f' dualLiveness g lookup z
instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
ppr = pprLgraph
+instance (Outputable l) => Outputable (ZLast l) where
+ ppr = pprLast
+
pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
pprTail (ZTail m t) = ppr m $$ ppr t
-pprTail (ZLast LastExit) = text "<exit>"
-pprTail (ZLast (LastOther l)) = ppr l
+pprTail (ZLast 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 g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
, ValueDirection(..)
+ , pprCmmGraphLikeCmm
)
where
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, 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 CLabel
+import CmmZipUtil
import ClosureInfo
import FastString
import ForeignCall
import MachOp
+import qualified ZipCfg as Z
import qualified ZipDataflow0 as DF
import ZipCfg
import MkZipCfg
import Util
+import UniqSet
import Maybes
import Outputable
import Prelude hiding (zip, unzip, last)
debugPpr = debugIsOn
pprMiddle :: Middle -> SDoc
-pprMiddle stmt = (case stmt of
+pprMiddle stmt = pp_stmt <+> pp_debug
+ where
+ pp_stmt = case stmt of
CopyIn conv args _ ->
if null args then ptext (sLit "empty CopyIn")
hcat [ ptext (sLit "return via ")
, ppr_target ra, parens (commafy $ map ppr args), semi ]
- ) <>
- if debugPpr then empty
- else text " //" <+>
- case stmt of
- CopyIn {} -> text "CopyIn"
- CopyOut {} -> text "CopyOut"
- MidComment {} -> text "MidComment"
- MidAssign {} -> text "MidAssign"
- MidStore {} -> text "MidStore"
- MidUnsafeCall {} -> text "MidUnsafeCall"
- MidAddToContext {} -> text "MidAddToContext"
+ pp_debug =
+ if not debugPpr then empty
+ else text " //" <+>
+ case stmt of
+ CopyIn {} -> text "CopyIn"
+ CopyOut {} -> text "CopyOut"
+ MidComment {} -> text "MidComment"
+ MidAssign {} -> text "MidAssign"
+ MidStore {} -> text "MidStore"
+ MidUnsafeCall {} -> text "MidUnsafeCall"
+ MidAddToContext {} -> text "MidAddToContext"
ppr_target :: CmmExpr -> SDoc
commafy :: [SDoc] -> SDoc
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
+
+with_out :: Maybe (Convention, CmmActuals) -> Last -> SDoc
+with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
+with_out (Just (conv, args)) l = last l
+ where last (LastCall e k) =
+ hcat [ptext (sLit "... = foreign "),
+ doubleQuotes(ppr conv), space,
+ ppr_target e, parens ( commafy $ map ppr args ),
+ ptext (sLit " \"safe\""),
+ case k of Nothing -> ptext (sLit " never returns")
+ Just _ -> empty,
+ semi ]
+ last (LastReturn) = ppr (CmmReturn args)
+ last (LastJump e) = ppr (CmmJump e args)
+ last l = ppr (CopyOut conv args) $$ ppr l
+ ppr_target (CmmLit lit) = ppr lit
+ ppr_target fn' = parens (ppr fn')
+ commafy xs = hsep $ punctuate comma xs
do { markFactsUnchanged
; b <- foldM trace_block b blocks
; changed <- factsStatus
- ; facts <- allFacts
+ ; facts <- getAllFacts
; let depth = 0 -- was nesting depth
; ppIter depth n $
case changed of
in do { fuel <-
run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
; a <- getFact (G.lg_entry graph)
- ; facts <- allFacts
+ ; facts <- getAllFacts
; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
return (fuel, a) }
solve_and_rewrite_b comp fuel graph exit_fact =
do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
- ; facts <- allFacts
+ ; facts <- getAllFacts
; (fuel, g) <- -- pass 2
my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph
- ; facts <- allFacts
+ ; facts <- getAllFacts
; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
return (fuel, a, g) }
where
m f a -> m f a
subAnalysis' m =
do { a <- subAnalysis $
- do { a <- m; facts <- allFacts
+ do { a <- m; facts <- getAllFacts
; my_trace "after sub-analysis facts are" (pprFacts facts) $
return a }
- ; facts <- allFacts
+ ; facts <- getAllFacts
; my_trace "in parent analysis facts are" (pprFacts facts) $
return a }
where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env