diff options
| -rw-r--r-- | compiler/cmm/CmmCPSZ.hs | 8 | ||||
| -rw-r--r-- | compiler/cmm/CmmLiveZ.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/CmmProcPointZ.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/CmmSpillReload.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/CmmUtils.hs | 1 | ||||
| -rw-r--r-- | compiler/cmm/DFMonad.hs | 24 | ||||
| -rw-r--r-- | compiler/cmm/OptimizationFuel.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 1 | ||||
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 48 | ||||
| -rw-r--r-- | compiler/cmm/StackColor.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/ZipCfg.hs | 10 | ||||
| -rw-r--r-- | compiler/cmm/ZipCfgCmmRep.hs | 146 | ||||
| -rw-r--r-- | compiler/cmm/ZipDataflow0.hs | 12 |
13 files changed, 215 insertions, 51 deletions
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 35c20c048e..3d8ac22f53 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 07801be49f..501d852095 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 059b5f29ff..fc6b726544 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 707a571b3f..a939d3dec1 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 675d44b716..c44cc3a53a 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 65c033ebb8..bbf2f9a007 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 bc32626c98..96272979ce 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 3673e7cdbd..fca199c738 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 2755312a5a..24b1287bef 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 "<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,-} @@ -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 94bb5c602d..6de602a432 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 f07d2fa56e..67a4ecdde6 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 "<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 "}" diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index ee1206eb70..1fda97139e 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 "<private-convention>" 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 diff --git a/compiler/cmm/ZipDataflow0.hs b/compiler/cmm/ZipDataflow0.hs index 00f15dbe35..fb2919308f 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 |