X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgCmmRep.hs;h=135a219e8d02d714c777466ab9e5d347d8f12b84;hb=1241c26f3552a2037263769e5ef7fa68d9f3be36;hp=71e206e4f638fca22d1b54292b956aa03c19f0c3;hpb=c0a5a5d2e41341046aaf37c1d2155372e7ed3ee8;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 71e206e..135a219 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} + -- This module is pure representation and should be imported only by -- clients that need to manipulate representation and know what @@ -7,6 +7,7 @@ module ZipCfgCmmRep ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..) + , ValueDirection(..) ) where @@ -29,8 +30,7 @@ import ZipCfg import MkZipCfg import Maybes -import Outputable hiding (empty) -import qualified Outputable as PP +import Outputable import Prelude hiding (zip, unzip, last) type CmmGraph = LGraph Middle Last @@ -50,15 +50,17 @@ data Middle | MidUnsafeCall -- An "unsafe" foreign call; CmmCallTarget -- just a fat machine instructoin - CmmFormals -- zero or more results + CmmFormals -- zero or more results CmmActuals -- zero or more arguments | CopyIn -- Move parameters or results from conventional locations to registers -- Note [CopyIn invariant] Convention - CmmFormals + CmmFormals -- eventually [CmmKind] will be used only for foreign + -- calls and will migrate into 'Convention' (helping to + -- drain "the swamp") C_SRT -- Static things kept alive by this block - | CopyOut Convention CmmFormals + | CopyOut Convention CmmActuals data Last = LastReturn CmmActuals -- Return from a function, @@ -72,8 +74,7 @@ data Last -- The parameters are unused at present. | LastCall { -- A call (native or safe foreign) - cml_target :: CmmCallTarget, - cml_actual :: CmmActuals, -- Zero or more arguments + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns | LastCondBranch { -- conditional branch @@ -88,18 +89,19 @@ data Last -- Undefined outside range, and when there's a Nothing data Convention - = Argument CCallConv -- Used for function formal params - | Result CCallConv -- Used for function results - - | Local -- Used for control transfers within a (pre-CPS) procedure + = 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)! deriving Eq --- ^ In a complete LGraph for a procedure, the [[Exit]] node should not --- appear, but it is useful in a subgraph (e.g., replacement for a node). +data ValueDirection = Arguments | Results + -- Arguments go with procedure definitions, jumps, and arguments to calls + -- Results go with returns and with results of calls. + deriving Eq {- Note [CopyIn invariant] @@ -124,20 +126,20 @@ instance LastNode Last where branchNodeTarget _ = panic "asked for target of non-branch" cmmSuccs :: Last -> [BlockId] -cmmSuccs (LastReturn {}) = [] -cmmSuccs (LastJump {}) = [] -cmmSuccs (LastBranch id _) = [id] -cmmSuccs (LastCall _ _ (Just id)) = [id] -cmmSuccs (LastCall _ _ Nothing) = [] -cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint -cmmSuccs (LastSwitch _ edges) = catMaybes edges +cmmSuccs (LastReturn {}) = [] +cmmSuccs (LastJump {}) = [] +cmmSuccs (LastBranch id _) = [id] +cmmSuccs (LastCall _ (Just id)) = [id] +cmmSuccs (LastCall _ Nothing) = [] +cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint +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 (LastCall _ _ (Just id)) z = f id z -fold_cmm_succs _f (LastCall _ _ Nothing) z = 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 @@ -157,12 +159,10 @@ instance Outputable Convention where instance DF.DebugNodes Middle Last instance Outputable CmmGraph where - ppr = pprCmmGraphAsRep + ppr = pprLgraph -pprCmmGraphAsRep :: CmmGraph -> SDoc -pprCmmGraphAsRep g = vcat (map ppr_block blocks) - where blocks = postorder_dfs g - ppr_block (Block id tail) = hang (ppr id <> colon) 4 (ppr tail) +debugPpr :: Bool +debugPpr = debugIsOn pprMiddle :: Middle -> SDoc pprMiddle stmt = (case stmt of @@ -175,7 +175,7 @@ pprMiddle stmt = (case stmt of ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...") CopyOut conv args -> - if null args then PP.empty + if null args then empty else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+> parens (commafy (map pprHinted args)) @@ -194,7 +194,7 @@ pprMiddle stmt = (case stmt of -- ToDo ppr volatile MidUnsafeCall (CmmCallee fn cconv) results args -> hcat [ if null results - then PP.empty + then empty else parens (commafy $ map ppr results) <> ptext SLIT(" = "), ptext SLIT("call"), space, @@ -209,15 +209,17 @@ pprMiddle stmt = (case stmt of pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) - ) <+> text "//" <+> - case stmt of - MidNop {} -> text "MidNop" - CopyIn {} -> text "CopyIn" - CopyOut {} -> text "CopyOut" - MidComment {} -> text "MidComment" - MidAssign {} -> text "MidAssign" - MidStore {} -> text "MidStore" - MidUnsafeCall {} -> text "MidUnsafeCall" + ) <> + if debugPpr then empty + else text " //" <+> + case stmt of + MidNop {} -> text "MidNop" + CopyIn {} -> text "CopyIn" + CopyOut {} -> text "CopyOut" + MidComment {} -> text "MidComment" + MidAssign {} -> text "MidAssign" + MidStore {} -> text "MidStore" + MidUnsafeCall {} -> text "MidUnsafeCall" pprHinted :: Outputable a => (a, MachHint) -> SDoc @@ -235,22 +237,23 @@ pprLast stmt = (case stmt of , parens ( commafy $ map pprHinted results ) , semi ] LastSwitch arg ids -> ppr $ CmmSwitch arg ids - LastCall tgt params k -> genCall tgt params k - ) <+> text "//" <+> - case stmt of - LastBranch {} -> text "LastBranch" - LastCondBranch {} -> text "LastCondBranch" - LastJump {} -> text "LastJump" - LastReturn {} -> text "LastReturn" - LastSwitch {} -> text "LastSwitch" - LastCall {} -> text "LastCall" - - -genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc -genCall (CmmCallee fn cconv) args k = + LastCall tgt k -> genBareCall tgt k + ) <> + if debugPpr then empty + else text " //" <+> + case stmt of + LastBranch {} -> text "LastBranch" + LastCondBranch {} -> text "LastCondBranch" + LastJump {} -> text "LastJump" + LastReturn {} -> text "LastReturn" + LastSwitch {} -> text "LastSwitch" + LastCall {} -> text "LastCall" + +genBareCall :: CmmExpr -> Maybe BlockId -> SDoc +genBareCall fn k = hcat [ ptext SLIT("foreign"), space - , doubleQuotes(ppr cconv), space - , target fn, parens ( commafy $ map pprHinted args ), space + , doubleQuotes(ptext SLIT("")), space + , target fn, parens ( ptext SLIT("") ), space , case k of Nothing -> ptext SLIT("never returns") Just k -> ptext SLIT("returns to") <+> ppr k , semi ] @@ -258,11 +261,6 @@ genCall (CmmCallee fn cconv) args k = target t@(CmmLit _) = ppr t target fn' = parens (ppr fn') -genCall (CmmPrim op) args k = - hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ), - ptext SLIT("returns to"), space, ppr k, - semi ] - genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+> @@ -279,9 +277,8 @@ genFullCondBranch expr t f = ] pprConvention :: Convention -> SDoc -pprConvention (Argument c) = ppr c -pprConvention (Result c) = ppr c -pprConvention Local = text "" +pprConvention (ConventionStandard c _) = ppr c +pprConvention (ConventionPrivate {} ) = text "" commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs