From 569348e87434f2a8d9e18dccac8b4a563b4eb363 Mon Sep 17 00:00:00 2001 From: Norman Ramsey Date: Wed, 12 Sep 2007 16:58:51 +0000 Subject: [PATCH] remove remaining redundancies from ZipCfgCmmRep -- LastBranch no longer takes parameters -- LastJump and LastReturn no longer carry CmmActuals; instead, those are carried by a CopyOut in the same basic block --- compiler/cmm/CmmContFlowOpt.hs | 4 +- compiler/cmm/CmmCvt.hs | 9 ++-- compiler/cmm/CmmLiveZ.hs | 6 +-- compiler/cmm/CmmProcPointZ.hs | 2 +- compiler/cmm/CmmSpillReload.hs | 6 +-- compiler/cmm/Dataflow.hs | 7 +-- compiler/cmm/MkZipCfgCmm.hs | 9 +++- compiler/cmm/PprCmmZ.hs | 5 +- compiler/cmm/ZipCfgCmmRep.hs | 106 +++++++++++++++++++++------------------- 9 files changed, 80 insertions(+), 74 deletions(-) diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 022b2dd..8f4e3f5 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -85,7 +85,7 @@ branchChainElimZ g@(G.LGraph eid _) lookup id = G.lookupBlockEnv env id `orElse` id isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock -isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target [])))) +isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target)))) | id /= target = Left (id,target) isLoneBranchZ other = Right other -- ^ An infinite loop is not a link in a branch chain! @@ -94,7 +94,7 @@ replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph replaceLabelsZ env = replace_eid . G.map_nodes id id last where replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks - last (LastBranch id args) = LastBranch (lookup id) args + last (LastBranch id) = LastBranch (lookup id) last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi) last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl) last (LastCall tgt (Just id)) = LastCall tgt (Just $ lookup id) diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index ae336b5..7beeb6b 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -95,8 +95,7 @@ ofZgraph g = ListGraph $ swallow blocks last id prev' out l n = let endblock stmt = block' id (stmt : prev') : swallow n in case l of - LastBranch _ (_:_) -> panic "unrepresentable branch" - LastBranch tgt [] -> + LastBranch tgt -> case n of G.Block id' t : bs | tgt == id', unique_pred id' @@ -116,8 +115,8 @@ ofZgraph g = ListGraph $ swallow blocks tail id (CmmCondBranch e' fid : prev') Nothing t bs _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n - LastJump expr params -> endblock $ CmmJump expr params - LastReturn params -> endblock $ CmmReturn params + LastJump expr -> endblock $ with_out out $ CmmJump expr + LastReturn -> endblock $ with_out out $ CmmReturn LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids LastCall e cont | Just (conv, args) <- out @@ -137,6 +136,8 @@ ofZgraph g = ListGraph $ swallow blocks in tail id (delayed : call : prev') Nothing t bs | otherwise -> panic "unrepairable call" | otherwise -> panic "call with no CopyOut" + with_out (Just (_conv, actuals)) f = f actuals + with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f []) findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt) findCopyIn (G.ZTail _ t) = findCopyIn t findCopyIn (G.ZLast _) = panic "missing CopyIn after call" diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 8a5d36c..2b502d5 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -67,9 +67,9 @@ middleLiveness m = middle m lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive lastLiveness l env = last l - where last (LastReturn ress) = gen ress emptyUniqSet - last (LastJump e args) = gen e $ gen args emptyUniqSet - last (LastBranch id args) = gen args $ env id + where last (LastReturn) = emptyUniqSet + last (LastJump e) = gen e $ emptyUniqSet + last (LastBranch id) = env id last (LastCall tgt (Just k)) = gen tgt $ env k last (LastCall tgt Nothing) = gen tgt $ emptyUniqSet last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f) diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index e250bf3..ac016a7 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -246,7 +246,7 @@ addProcPointProtocols procPoints formals g = let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse` panic "jump out of graph" in case t of - ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee []))) + ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee))) | elemBlockSet pee procPoints -> Just pee _ -> Nothing init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 7d4f42c..63e0058 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -113,9 +113,9 @@ middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) liv lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive lastDualLiveness env l = last l - where last (LastReturn ress) = changeRegs (gen ress) empty - last (LastJump e args) = changeRegs (gen e . gen args) empty - last (LastBranch id args) = changeRegs (gen args) $ env id + where last (LastReturn) = empty + last (LastJump e) = changeRegs (gen e) empty + last (LastBranch id) = env id last (LastCall tgt Nothing) = changeRegs (gen tgt) empty last (LastCall tgt (Just k)) = -- nothing can be live in registers at this point diff --git a/compiler/cmm/Dataflow.hs b/compiler/cmm/Dataflow.hs index 35cf266..35fdebb 100644 --- a/compiler/cmm/Dataflow.hs +++ b/compiler/cmm/Dataflow.hs @@ -1,9 +1,4 @@ -{-# 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 +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module Dataflow ( fixedpoint diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 9a92f6f..6ddec3d 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -69,13 +69,18 @@ mkComment fs = mkMiddle $ MidComment fs mkAssign l r = mkMiddle $ MidAssign l r mkStore l r = mkMiddle $ MidStore l r -mkJump e args = mkLast $ LastJump e args mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot -mkReturn actuals = mkLast $ LastReturn actuals mkSwitch e tbl = mkLast $ LastSwitch e tbl mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals +cmmArgConv, cmmResConv :: Convention +cmmArgConv = ConventionStandard CmmCallConv Arguments +cmmResConv = ConventionStandard CmmCallConv Arguments + +mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e) +mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn + mkFinalCall f conv actuals = mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> mkLast (LastCall f Nothing) diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index 18302d8..e9b2d6c 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -47,13 +47,12 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) last id prev' out l n = let endblock stmt = block' id (stmt : prev') : swallow n in case l of - G.LastBranch tgt [] -> + G.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@(G.LastBranch {}) -> endblock $ with_out out l l@(G.LastCondBranch expr tid fid) -> let ft id = text "// fall through to " <> ppr id in case n of @@ -123,6 +122,8 @@ with_out (Just (conv, args)) l = last l case k of Nothing -> ptext SLIT(" never returns") Just _ -> empty, semi ] + last (G.LastReturn) = ppr (CmmReturn args) + last (G.LastJump e) = ppr (CmmJump e args) last l = ppr (G.CopyOut conv args) $$ ppr l ppr_target (CmmLit lit) = pprLit lit ppr_target fn' = parens (ppr fn') diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 135a219..03fc759 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -15,8 +15,8 @@ where import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals - , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr + , CmmCallTarget(..), CmmActuals, CmmFormals + , CmmStmt(CmmSwitch) -- imported in order to call ppr ) import PprCmm() @@ -33,6 +33,9 @@ import Maybes import Outputable import Prelude hiding (zip, unzip, last) +---------------------------------------------------------------------- +----- Type synonyms and definitions + type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last type CmmBlock = Block Middle Last @@ -53,35 +56,38 @@ data Middle CmmFormals -- zero or more results CmmActuals -- zero or more arguments - | CopyIn -- Move parameters or results from conventional locations to registers - -- Note [CopyIn invariant] + | CopyIn -- Move incoming parameters or results from conventional + -- locations to registers. Note [CopyIn invariant] Convention CmmFormals -- eventually [CmmKind] will be used only for foreign -- calls and will migrate into 'Convention' (helping to - -- drain "the swamp") + -- drain "the swamp"), leaving this as [LocalReg] C_SRT -- Static things kept alive by this block + | CopyOut Convention CmmActuals + -- Move outgoing parameters or results from registers to + -- conventional locations. Every 'LastReturn', + -- 'LastJump', or 'LastCall' must be dominated by a + -- matching 'CopyOut' in the same basic block. + -- As above, '[CmmKind]' will migrate into the foreign calling + -- convention, leaving the actuals as '[CmmExpr]'. data Last - = LastReturn CmmActuals -- Return from a function, - -- with these return values. - - | LastJump CmmExpr CmmActuals - -- Tail call to another procedure - - | LastBranch BlockId CmmFormalsWithoutKinds - -- To another block in the same procedure - -- The parameters are unused at present. - - | LastCall { -- A call (native or safe foreign) - cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! - cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns + = LastBranch BlockId -- Goto another block in the same procedure | LastCondBranch { -- conditional branch cml_pred :: CmmExpr, cml_true, cml_false :: BlockId } + | LastReturn -- Return from a function; values in a previous CopyOut node + + | LastJump CmmExpr -- Tail call to another procedure; args in a CopyOut node + + | LastCall { -- A call (native or safe foreign) + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! + cml_cont :: Maybe BlockId } -- BlockId of continuation, if call returns + | LastSwitch CmmExpr [Maybe BlockId] -- Table branch -- The scrutinee is zero-based; -- zero -> first block @@ -91,11 +97,12 @@ data Last data Convention = ConventionStandard CCallConv ValueDirection | ConventionPrivate - -- Used for control transfers within a (pre-CPS) procedure - -- All jump sites known, never pushed on the stack (hence no SRT) - -- You can choose whatever calling convention - -- you please (provided you make sure - -- all the call sites agree)! + -- Used for control transfers within a (pre-CPS) procedure All + -- jump sites known, never pushed on the stack (hence no SRT) + -- You can choose whatever calling convention you please + -- (provided you make sure all the call sites agree)! + -- This data type eventually to be extended to record the convention. + deriving Eq data ValueDirection = Arguments | Results @@ -106,29 +113,31 @@ data ValueDirection = Arguments | Results {- Note [CopyIn invariant] ~~~~~~~~~~~~~~~~~~~~~~~ -In principle, CopyIn ought to be a First node, but in practice, the +One might wish for CopyIn to be a First node, but in practice, the possibility raises all sorts of hairy issues with graph splicing, rewriting, and so on. In the end, NR finds it better to make the -placement of CopyIn a dynamic invariant. This change will complicate -the dataflow fact for the proc-point calculation, but it should make -things easier in many other respects. +placement of CopyIn a dynamic invariant; it should normally be the first +Middle node in the basic block in which it occurs. -} +---------------------------------------------------------------------- +----- Instance declarations for control flow + instance HavingSuccessors Last where succs = cmmSuccs fold_succs = fold_cmm_succs instance LastNode Last where - mkBranchNode id = LastBranch id [] - isBranchNode (LastBranch _ []) = True + mkBranchNode id = LastBranch id + isBranchNode (LastBranch _) = True isBranchNode _ = False - branchNodeTarget (LastBranch id []) = id + branchNodeTarget (LastBranch id) = id branchNodeTarget _ = panic "asked for target of non-branch" cmmSuccs :: Last -> [BlockId] cmmSuccs (LastReturn {}) = [] cmmSuccs (LastJump {}) = [] -cmmSuccs (LastBranch id _) = [id] +cmmSuccs (LastBranch id) = [id] cmmSuccs (LastCall _ (Just id)) = [id] cmmSuccs (LastCall _ Nothing) = [] cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint @@ -137,15 +146,15 @@ cmmSuccs (LastSwitch _ edges) = catMaybes edges fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a fold_cmm_succs _f (LastReturn {}) z = z fold_cmm_succs _f (LastJump {}) z = z -fold_cmm_succs f (LastBranch id _) z = f id z +fold_cmm_succs f (LastBranch id) z = f id z fold_cmm_succs f (LastCall _ (Just id)) z = f id z fold_cmm_succs _f (LastCall _ Nothing) z = z fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z) fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges ----------------------------------------------------------------- --- prettyprinting (avoids recursive imports) +---------------------------------------------------------------------- +----- Instance declarations for prettyprinting (avoids recursive imports) instance Outputable Middle where ppr s = pprMiddle s @@ -175,9 +184,8 @@ pprMiddle stmt = (case stmt of ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...") CopyOut conv args -> - if null args then empty - else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+> - parens (commafy (map pprHinted args)) + ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+> + parens (commafy (map pprHinted args)) -- // text MidComment s -> text "//" <+> ftext s @@ -230,12 +238,12 @@ pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a pprLast :: Last -> SDoc pprLast stmt = (case stmt of - LastBranch ident args -> genBranchWithArgs ident args + LastBranch ident -> ptext SLIT("goto") <+> ppr ident <> semi LastCondBranch expr t f -> genFullCondBranch expr t f - LastJump expr params -> ppr $ CmmJump expr params - LastReturn results -> hcat [ ptext SLIT("return"), space - , parens ( commafy $ map pprHinted results ) - , semi ] + LastJump expr -> hcat [ ptext SLIT("jump"), space, pprFun expr + , ptext SLIT("(...)"), semi] + LastReturn -> hcat [ ptext SLIT("return"), space + , ptext SLIT("(...)"), semi] LastSwitch arg ids -> ppr $ CmmSwitch arg ids LastCall tgt k -> genBareCall tgt k ) <> @@ -251,20 +259,16 @@ pprLast stmt = (case stmt of genBareCall :: CmmExpr -> Maybe BlockId -> SDoc genBareCall fn k = - hcat [ ptext SLIT("foreign"), space - , doubleQuotes(ptext SLIT("")), space - , target fn, parens ( ptext SLIT("") ), space + hcat [ ptext SLIT("call"), space + , pprFun fn, ptext SLIT("(...)"), space , case k of Nothing -> ptext SLIT("never returns") Just k -> ptext SLIT("returns to") <+> ppr k , semi ] where - target t@(CmmLit _) = ppr t - target fn' = parens (ppr fn') -genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc -genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi -genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+> - parens (commafy (map ppr args)) <> semi +pprFun :: CmmExpr -> SDoc +pprFun f@(CmmLit _) = ppr f +pprFun f = parens (ppr f) genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc genFullCondBranch expr t f = -- 1.7.10.4