--- /dev/null
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+module ZipCfgCmm
+ ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall
+ , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
+ , mkCmmWhileDo
+ , mkCopyIn, mkCopyOut
+ , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
+ )
+where
+
+#include "HsVersions.h"
+
+import CmmExpr
+import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
+ , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHintFormals
+ , CmmStmt(CmmJump, CmmSwitch, CmmReturn) -- imported in order to call ppr
+ )
+import PprCmm()
+
+import CLabel
+import ClosureInfo
+import FastString
+import ForeignCall
+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
+type CmmBlock = Block Middle Last
+type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
+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
+mkFinalCall :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
+mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
+mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
+mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
+mkReturn :: CmmActuals -> CmmAGraph
+mkComment :: FastString -> CmmAGraph
+
+-- Not to be forgotten, but exported by MkZipCfg:
+--mkBranch :: BlockId -> CmmAGraph
+--mkLabel :: BlockId -> CmmAGraph
+mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
+mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
+
+--------------------------------------------------------------------------
+
+mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
+mkCmmWhileDo e = mkWhileDo (mkCbranch e)
+
+mkCopyIn :: Convention -> CmmHintFormals -> C_SRT -> CmmAGraph
+mkCopyOut :: Convention -> CmmHintFormals -> CmmAGraph
+
+ -- ^ XXX: Simon or Simon thinks maybe the hints are being abused and
+ -- we should have CmmFormals here, but for now it is CmmHintFormals
+ -- for consistency with the rest of the back end ---NR
+
+mkComment fs = mkMiddle (MidComment fs)
+
+data Middle
+ = MidNop
+ | MidComment FastString
+
+ | MidAssign CmmReg CmmExpr -- Assign to register
+
+ | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
+ -- given by cmmExprRep of the rhs.
+
+ | MidUnsafeCall -- An "unsafe" foreign call;
+ CmmCallTarget -- just a fat machine instructoin
+ CmmHintFormals -- zero or more results
+ CmmActuals -- zero or more arguments
+
+ | CopyIn -- Move parameters or results from conventional locations to registers
+ -- Note [CopyIn invariant]
+ Convention
+ CmmHintFormals
+ C_SRT -- Static things kept alive by this block
+ | CopyOut Convention CmmHintFormals
+
+data Last
+ = LastReturn CmmActuals -- Return from a function,
+ -- with these return values.
+
+ | LastJump CmmExpr CmmActuals
+ -- Tail call to another procedure
+
+ | LastBranch BlockId CmmFormals
+ -- To another block in the same procedure
+ -- The parameters are unused at present.
+
+ | 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
+
+ | LastCondBranch { -- conditional branch
+ cml_pred :: CmmExpr,
+ cml_true, cml_false :: BlockId
+ }
+
+ | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
+ -- The scrutinee is zero-based;
+ -- zero -> first block
+ -- one -> second block etc
+ -- 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)!
+ 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).
+
+{-
+Note [CopyIn invariant]
+~~~~~~~~~~~~~~~~~~~~~~~
+In principle, CopyIn ought 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.
+-}
+
+
+-- ================ IMPLEMENTATION ================--
+
+mkNop = mkMiddle $ MidNop
+mkAssign l r = mkMiddle $ MidAssign l r
+mkStore l r = mkMiddle $ MidStore l r
+mkCopyIn conv args srt = mkMiddle $ CopyIn conv args srt
+mkCopyOut conv args = mkMiddle $ CopyOut conv args
+
+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
+mkFinalCall tgt actuals = mkLast $ LastCall tgt actuals Nothing
+
+mkCall tgt results actuals srt =
+ withFreshLabel "call successor" $ \k ->
+ mkLast (LastCall tgt actuals (Just k)) <*>
+ mkLabel k <*>
+ mkCopyIn (Result CmmCallConv) results srt
+
+instance HavingSuccessors Last where
+ succs = cmmSuccs
+ fold_succs = fold_cmm_succs
+
+instance LastNode Last where
+ mkBranchNode id = LastBranch id []
+ isBranchNode (LastBranch _ []) = True
+ isBranchNode _ = False
+ 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
+
+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 (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 Outputable Middle where
+ ppr s = pprMiddle s
+
+instance Outputable Last where
+ ppr s = pprLast s
+
+instance Outputable Convention where
+ ppr = pprConvention
+
+pprMiddle :: Middle -> SDoc
+pprMiddle stmt = case stmt of
+
+ MidNop -> semi
+
+ CopyIn conv args _ ->
+ if null args then ptext SLIT("empty CopyIn")
+ else commafy (map ppr 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))
+
+ -- // text
+ MidComment s -> text "//" <+> ftext s
+
+ -- reg = expr;
+ MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+ -- rep[lv] = expr;
+ MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ where
+ rep = ppr ( cmmExprRep expr )
+
+ -- call "ccall" foo(x, y)[r1, r2];
+ -- ToDo ppr volatile
+ MidUnsafeCall (CmmCallee fn cconv) results args ->
+ hcat [ if null results
+ then PP.empty
+ else parens (commafy $ map ppr results) <>
+ ptext SLIT(" = "),
+ ptext SLIT("call"), space,
+ doubleQuotes(ppr cconv), space,
+ 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)
+
+
+pprLast :: Last -> SDoc
+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
+ LastSwitch arg ids -> ppr $ CmmSwitch arg ids
+ LastCall tgt params k -> genCall tgt params k
+
+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 ]
+ 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 ),
+ 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
+
+genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
+genFullCondBranch expr t f =
+ hsep [ ptext SLIT("if")
+ , parens(ppr expr)
+ , ptext SLIT("goto")
+ , ppr t <> semi
+ , ptext SLIT("else goto")
+ , ppr f <> semi
+ ]
+
+pprConvention :: Convention -> SDoc
+pprConvention (Argument c) = ppr c
+pprConvention (Result c) = ppr c
+pprConvention Local = text "<local>"
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
projects / ghc-hetmet.git / blobdiff