import FastString
import ForeignCall
import MachOp
-import qualified ZipDataflow as DF
+import qualified ZipDataflow0 as DF
import ZipCfg
import MkZipCfg
type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
data Middle
- = MidNop
- | MidComment FastString
+ = MidComment FastString
| MidAssign CmmReg CmmExpr -- Assign to register
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
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 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)
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(" = "),
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