X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgCmm.hs;h=2a68502bb67c048ffab9f7921ccb2f6b54587550;hb=e8b6200f76059a091e6ae7a03821143819561727;hp=367d95229e581f15d14fe682776fd4aeadead6e2;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipCfgCmm.hs b/compiler/cmm/ZipCfgCmm.hs index 367d952..2a68502 100644 --- a/compiler/cmm/ZipCfgCmm.hs +++ b/compiler/cmm/ZipCfgCmm.hs @@ -12,8 +12,8 @@ where import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHintFormals - , CmmStmt(CmmJump, CmmSwitch, CmmReturn) -- imported in order to call ppr + , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals + , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr ) import PprCmm() @@ -21,12 +21,15 @@ import CLabel import ClosureInfo import FastString import ForeignCall +import MachOp +import qualified ZipDataflow as DF +import ZipCfg +import MkZipCfg + import Maybes import Outputable hiding (empty) import qualified Outputable as PP import Prelude hiding (zip, unzip, last) -import ZipCfg -import MkZipCfg type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last @@ -37,8 +40,8 @@ type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph mkNop :: CmmAGraph mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph -mkCall :: CmmCallTarget -> CmmHintFormals -> CmmActuals -> C_SRT -> CmmAGraph -mkUnsafeCall :: CmmCallTarget -> CmmHintFormals -> CmmActuals -> CmmAGraph +mkCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph +mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph mkFinalCall :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns mkJump :: CmmExpr -> CmmActuals -> CmmAGraph mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph @@ -57,11 +60,11 @@ mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph mkCmmIfThenElse e = mkIfThenElse (mkCbranch e) mkCmmWhileDo e = mkWhileDo (mkCbranch e) -mkCopyIn :: Convention -> CmmHintFormals -> C_SRT -> CmmAGraph -mkCopyOut :: Convention -> CmmHintFormals -> CmmAGraph +mkCopyIn :: Convention -> CmmFormals -> C_SRT -> CmmAGraph +mkCopyOut :: Convention -> CmmFormals -> CmmAGraph -- ^ XXX: Simon or Simon thinks maybe the hints are being abused and - -- we should have CmmFormals here, but for now it is CmmHintFormals + -- we should have CmmFormalsWithoutKinds here, but for now it is CmmFormals -- for consistency with the rest of the back end ---NR mkComment fs = mkMiddle (MidComment fs) @@ -77,15 +80,15 @@ data Middle | MidUnsafeCall -- An "unsafe" foreign call; CmmCallTarget -- just a fat machine instructoin - CmmHintFormals -- 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 - CmmHintFormals + CmmFormals C_SRT -- Static things kept alive by this block - | CopyOut Convention CmmHintFormals + | CopyOut Convention CmmFormals data Last = LastReturn CmmActuals -- Return from a function, @@ -94,7 +97,7 @@ data Last | LastJump CmmExpr CmmActuals -- Tail call to another procedure - | LastBranch BlockId CmmFormals + | LastBranch BlockId CmmFormalsWithoutKinds -- To another block in the same procedure -- The parameters are unused at present. @@ -204,20 +207,30 @@ instance Outputable Last where instance Outputable Convention where ppr = pprConvention +instance DF.DebugNodes Middle Last + +instance Outputable CmmGraph where + ppr = pprCmmGraphAsRep + +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) + pprMiddle :: Middle -> SDoc -pprMiddle stmt = case stmt of +pprMiddle stmt = (case stmt of MidNop -> semi CopyIn conv args _ -> if null args then ptext SLIT("empty CopyIn") - else commafy (map ppr args) <+> equals <+> + else commafy (map pprHinted args) <+> equals <+> ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...") CopyOut conv args -> if null args then PP.empty else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+> - parens (commafy (map ppr args)) + parens (commafy (map pprHinted args)) -- // text MidComment s -> text "//" <+> ftext s @@ -249,32 +262,57 @@ 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" + + +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 pprLast :: Last -> SDoc -pprLast stmt = case stmt of - +pprLast stmt = (case stmt of LastBranch ident args -> genBranchWithArgs ident args LastCondBranch expr t f -> genFullCondBranch expr t f LastJump expr params -> ppr $ CmmJump expr params - LastReturn params -> ppr $ CmmReturn params + LastReturn results -> hcat [ ptext SLIT("return"), space + , 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 = - hcat [ ptext SLIT("foreign"), space, - doubleQuotes(ppr cconv), space, - target fn, parens ( commafy $ map ppr args ), - case k of Nothing -> ptext SLIT("never returns") - Just k -> ptext SLIT("returns to") <+> ppr k, - semi ] + hcat [ ptext SLIT("foreign"), space + , doubleQuotes(ppr cconv), space + , target fn, parens ( commafy $ map pprHinted args ), 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 ppr args ), + hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ), ptext SLIT("returns to"), space, ppr k, semi ]