X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgCmmRep.hs;h=ee1206eb7039798be705dbf4f36fb815343440a0;hb=a1515d75e38a32d69636c98bb590f6195e2ab3d1;hp=d4ed3cfde9c9906e5d9172456e696aed1ec49eba;hpb=4ddba4629c5396bec766b598fe32d874a378d7bb;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index d4ed3cf..ee1206e 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -11,11 +11,9 @@ module ZipCfgCmmRep ) where -#include "HsVersions.h" - import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals + , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..) , CmmStmt(CmmSwitch) -- imported in order to call ppr ) import PprCmm() @@ -25,9 +23,10 @@ import ClosureInfo import FastString import ForeignCall import MachOp -import qualified ZipDataflow as DF +import qualified ZipDataflow0 as DF import ZipCfg import MkZipCfg +import Util import Maybes import Outputable @@ -43,8 +42,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 @@ -56,6 +54,14 @@ data Middle CmmFormals -- zero or more results CmmActuals -- zero or more arguments + | 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 @@ -152,6 +158,29 @@ 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 +---------------------------------------------------------------------- +----- 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 declarations for prettyprinting (avoids recursive imports) @@ -167,24 +196,19 @@ instance Outputable Convention where instance DF.DebugNodes Middle Last -instance Outputable CmmGraph where - ppr = pprLgraph - debugPpr :: Bool debugPpr = debugIsOn pprMiddle :: Middle -> SDoc pprMiddle stmt = (case stmt of - MidNop -> semi - CopyIn conv args _ -> - if null args then ptext SLIT("empty CopyIn") + if null args then ptext (sLit "empty CopyIn") else commafy (map pprHinted args) <+> equals <+> - ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...") + ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...") CopyOut conv args -> - ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+> + ptext (sLit "next, pass") <+> doubleQuotes(ppr conv) <+> parens (commafy (map pprHinted args)) -- // text @@ -204,46 +228,53 @@ pprMiddle stmt = (case stmt of hcat [ if null results then empty else parens (commafy $ map ppr results) <> - ptext SLIT(" = "), - ptext SLIT("call"), space, + 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 -pprHinted (a, NoHint) = ppr a -pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a -pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a -pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a +pprHinted :: Outputable a => CmmHinted a -> SDoc +pprHinted (CmmHinted a NoHint) = ppr a +pprHinted (CmmHinted a PtrHint) = doubleQuotes (text "address") <+> ppr a +pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a +pprHinted (CmmHinted a FloatHint) = doubleQuotes (text "float") <+> ppr a pprLast :: Last -> SDoc pprLast stmt = (case stmt of - LastBranch ident -> ptext SLIT("goto") <+> ppr ident <> semi + LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi LastCondBranch expr t f -> genFullCondBranch expr t f - LastJump expr -> hcat [ ptext SLIT("jump"), space, pprFun expr - , ptext SLIT("(...)"), semi] - LastReturn -> hcat [ ptext SLIT("return"), space - , ptext SLIT("(...)"), 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 ) <> @@ -259,10 +290,10 @@ pprLast stmt = (case stmt of 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 + 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 @@ -272,11 +303,11 @@ pprFun f = parens (ppr f) genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc genFullCondBranch expr t f = - hsep [ ptext SLIT("if") + hsep [ ptext (sLit "if") , parens(ppr expr) - , ptext SLIT("goto") + , ptext (sLit "goto") , ppr t <> semi - , ptext SLIT("else goto") + , ptext (sLit "else goto") , ppr f <> semi ]