X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgCmmRep.hs;h=c5464e2b42bf464fb455a5e32b7183cfb2abd3cf;hb=fee569a69a4ce8c8d05b8a1fb8069d804dbd2b9c;hp=0d367ad33ecabb33c0cc9de294e4fedd673289f5;hpb=7457c489e32a326224673a07281ae402ee4d25fc;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 0d367ad..c5464e2 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 @@ -14,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() @@ -24,7 +25,7 @@ import ClosureInfo import FastString import ForeignCall import MachOp -import qualified ZipDataflow as DF +import qualified ZipDataflow0 as DF import ZipCfg import MkZipCfg @@ -32,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 @@ -39,8 +43,7 @@ type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph data Middle - = MidNop - | MidComment FastString + = MidComment FastString | MidAssign CmmReg CmmExpr -- Assign to register @@ -49,37 +52,49 @@ 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] + | MidAddToContext -- push a frame on the stack; + -- I will return to this frame + CmmExpr -- The frame's return address; it must be + -- preceded by an info table that describes the + -- live variables. + [CmmExpr] -- The frame's live variables, to go on the + -- stack with the first one at the young end + + | CopyIn -- Move incoming 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"), leaving this as [LocalReg] C_SRT -- Static things kept alive by this block - | CopyOut Convention CmmFormals - -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. + | 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]'. - | LastCall { -- A call (native or safe foreign) - cml_target :: CmmCallTarget, - cml_actual :: CmmActuals, -- Zero or more arguments - cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns +data Last + = 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); args in CopyOut node + 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 @@ -87,62 +102,93 @@ 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 - -- 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)! + = 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)! + -- This data type eventually to be extended to record the convention. + 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] ~~~~~~~~~~~~~~~~~~~~~~~ -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 (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 (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 register use + +instance UserOfLocalRegs Middle where + foldRegsUsed f z m = middle m + where middle (MidComment {}) = z + middle (MidAssign _lhs expr) = fold f z expr + middle (MidStore addr rval) = fold f (fold f z addr) rval + middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args + middle (MidAddToContext ra args) = fold f (fold f z ra) args + middle (CopyIn _ _formals _) = z + middle (CopyOut _ actuals) = fold f z actuals + fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction + +instance UserOfLocalRegs Last where + foldRegsUsed f z m = last m + where last (LastReturn) = z + last (LastJump e) = foldRegsUsed f z e + last (LastBranch _id) = z + last (LastCall tgt _) = foldRegsUsed f z tgt + last (LastCondBranch e _ _) = foldRegsUsed f z e + last (LastSwitch e _tbl) = foldRegsUsed f z e + +instance UserOfLocalRegs (ZLast Last) where + foldRegsUsed f z (LastOther l) = foldRegsUsed f z l + foldRegsUsed _f z LastExit = z + + +---------------------------------------------------------------------- +----- Instance declarations for prettyprinting (avoids recursive imports) instance Outputable Middle where ppr s = pprMiddle s @@ -159,26 +205,19 @@ instance Outputable CmmGraph where ppr = pprLgraph debugPpr :: Bool -#ifdef DEBUG -debugPpr = True -#else -debugPpr = False -#endif +debugPpr = debugIsOn pprMiddle :: Middle -> SDoc pprMiddle stmt = (case stmt of - MidNop -> semi - CopyIn conv args _ -> if null args then ptext SLIT("empty CopyIn") else commafy (map pprHinted args) <+> equals <+> 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 @@ -200,27 +239,34 @@ pprMiddle stmt = (case stmt of ptext SLIT(" = "), ptext SLIT("call"), space, doubleQuotes(ppr cconv), space, - target fn, parens ( commafy $ map ppr args ), + ppr_target fn, parens ( commafy $ map ppr args ), semi ] - where - target t@(CmmLit _) = ppr t - target fn' = parens (ppr fn') MidUnsafeCall (CmmPrim op) results args -> pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) + + MidAddToContext ra args -> + hcat [ ptext SLIT("return via ") + , ppr_target ra, parens (commafy $ map ppr args), semi ] + ) <> 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" + MidUnsafeCall {} -> text "MidUnsafeCall" + MidAddToContext {} -> text "MidAddToContext" + + +ppr_target :: CmmExpr -> SDoc +ppr_target t@(CmmLit _) = ppr t +ppr_target fn' = parens (ppr fn') pprHinted :: Outputable a => (a, MachHint) -> SDoc @@ -231,14 +277,14 @@ 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 params k -> genCall tgt params k + LastCall tgt k -> genBareCall tgt k ) <> if debugPpr then empty else text " //" <+> @@ -250,27 +296,18 @@ pprLast stmt = (case stmt of LastSwitch {} -> text "LastSwitch" LastCall {} -> text "LastCall" -genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc -genCall (CmmCallee fn cconv) args k = - hcat [ ptext SLIT("foreign"), space - , doubleQuotes(ppr cconv), space - , target fn, parens ( commafy $ map pprHinted args ), space +genBareCall :: CmmExpr -> Maybe BlockId -> SDoc +genBareCall fn k = + 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') - -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 <+> - 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 = @@ -283,9 +320,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