From: Norman Ramsey Date: Sat, 3 May 2008 22:34:52 +0000 (+0000) Subject: minor changes to Cmm left over from September 2007 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ba60dc74fdb18fe655cfac605130cf6480116e47 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... --- diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 35c20c0..3d8ac22 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -1,4 +1,3 @@ - module CmmCPSZ ( -- | Converts C-- with full proceedures and parameters -- to a CPS transformed C-- with the stack made manifest. @@ -31,6 +30,9 @@ protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm -> 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] @@ -58,13 +60,17 @@ cpsTop (CmmProc h l args g) = 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 } } diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 07801be..501d852 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -41,7 +41,7 @@ type BlockEntryLiveness = BlockEnv CmmLive ----------------------------------------------------------------------------- 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 diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 059b5f2..fc6b726 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -132,7 +132,7 @@ extendPPSet g blocks procPoints = 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 diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 707a571..a939d3d 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -205,7 +205,8 @@ data AvailRegs = UniverseMinus RegSet 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 = @@ -241,7 +242,7 @@ cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs 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 diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 675d44b..c44cc3a 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -128,6 +128,7 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off] -- 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) diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index 65c033e..bbf2f9a 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -3,13 +3,13 @@ module DFMonad ( 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 @@ -123,11 +123,12 @@ class DataflowAnalysis m where 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 } @@ -163,6 +164,10 @@ instance DataflowAnalysis DFA where 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 @@ -173,15 +178,13 @@ instance DataflowAnalysis DFA where 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", @@ -213,7 +216,8 @@ instance DataflowAnalysis DFM where 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 @@ -229,6 +233,10 @@ markGraphRewritten :: DFM f () 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 diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index bc32626..9627297 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -7,6 +7,7 @@ module OptimizationFuel , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState , fuelDecrementState , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass + , runWithInfiniteFuel , FuelMonad(..) ) where @@ -59,6 +60,8 @@ fuelConsumingPass name f = do fuel <- fuelRemaining 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) = @@ -78,6 +81,8 @@ runFuel (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) +runWithInfiniteFuel (FuelMonad f) = fst $ f $ initialFuelState $ tankFilledTo maxBound + lastFuelPassInState :: FuelState -> String lastFuelPassInState = fs_lastpass diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 3673e7c..fca199c 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -34,6 +34,7 @@ module PprC ( -- Cmm stuff import Cmm +import PprCmm () -- Instances only import CLabel import MachOp import ForeignCall diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 2755312..24b1287 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -1,10 +1,3 @@ -{-# 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-- @@ -92,6 +85,9 @@ instance Outputable CmmExpr where instance Outputable CmmReg where ppr e = pprReg e +instance Outputable CmmLit where + ppr l = pprLit l + instance Outputable LocalReg where ppr e = pprLocalReg e @@ -145,12 +141,13 @@ instance Outputable CmmSafety where -- 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 "")) pprBlockId gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) 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 "")) pprBlockId gc_target,-} @@ -161,12 +158,13 @@ pprInfo (CmmInfo gc_target update_frame 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, @@ -241,8 +239,22 @@ pprStmt stmt = case stmt of 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) @@ -341,7 +353,7 @@ genSwitch expr maybe_ids 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 @@ -379,10 +391,13 @@ pprExpr e -- 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 "<<")) @@ -479,8 +494,9 @@ pprLit lit = case lit of 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 @@ -569,4 +585,4 @@ pprBlockId b = ppr $ getUnique b ----------------------------------------------------------------------------- commafy :: [SDoc] -> SDoc -commafy xs = hsep $ punctuate comma xs +commafy xs = fsep $ punctuate comma xs diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs index 94bb5c6..6de602a 100644 --- a/compiler/cmm/StackColor.hs +++ b/compiler/cmm/StackColor.hs @@ -23,7 +23,7 @@ type M = ExtendWithSpills Middle 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 diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index f07d2fa..67a4ecd 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -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 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 "" -pprTail (ZLast (LastOther l)) = ppr l +pprTail (ZLast l) = ppr l + +pprLast :: (Outputable l) => ZLast l -> SDoc +pprLast LastExit = text "" +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 "}" diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index ee1206e..1fda971 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -8,26 +8,33 @@ 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) @@ -200,7 +207,9 @@ debugPpr :: Bool 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") @@ -243,17 +252,17 @@ pprMiddle stmt = (case stmt of 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 @@ -317,3 +326,114 @@ pprConvention (ConventionPrivate {} ) = text "" 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 "" : 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 "// ") + Just (conv, args) -> endblock (ppr (CopyOut conv args) $$ + text "// ") + 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 diff --git a/compiler/cmm/ZipDataflow0.hs b/compiler/cmm/ZipDataflow0.hs index 00f15db..fb29193 100644 --- a/compiler/cmm/ZipDataflow0.hs +++ b/compiler/cmm/ZipDataflow0.hs @@ -299,7 +299,7 @@ run dir name set_entry do_block b blocks = 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 @@ -442,7 +442,7 @@ solve_graph_b comp fuel graph exit_fact = 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) } @@ -496,11 +496,11 @@ solve_and_rewrite_b_graph :: 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 @@ -1079,10 +1079,10 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => 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