Commit b822c1e4 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

change the zipper representation of calls

This patch combines two changes:
  1. As requested by SimonPJ, the redundancy inherent in having
     LastCall bear actual parameters has been removed.  The actual
     parameters are now carried by a separate CopyOut node.
  2. The internal (to zipper) representation of calls has changed;
     the representation of calling conventions is more orthogonal,
     and there is now no such thing as a 'safe' or 'final' call
     to a CallishMachOp.   This change has affected the interface
     to MkZipCfgCmm, which now provides a static guarantee.  Simon's
     new upstream code will be affected; I've patched the existing
     code in CmmCvt (which becomes ever hairier).
  
parent d068f78b
......@@ -93,12 +93,12 @@ isLoneBranchZ other = Right other
replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph
replaceLabelsZ env = replace_eid . G.map_nodes id id last
where
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
last (LastBranch id args) = LastBranch (lookup id) args
last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
last (LastCall tgt args (Just id)) = LastCall tgt args (Just $ lookup id)
last exit_jump_return = exit_jump_return
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
last (LastBranch id args) = LastBranch (lookup id) args
last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
last (LastCall tgt (Just id)) = LastCall tgt (Just $ lookup id)
last exit_jump_return = exit_jump_return
lookup id = G.lookupBlockEnv env id `orElse` id
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
......
......@@ -4,19 +4,23 @@
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
import Cmm
import CmmExpr
import MkZipCfgCmm hiding (CmmGraph)
import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
import PprCmm()
import PprCmmZ()
import qualified ZipCfg as G
import FastString
import Outputable
import Panic
import PprCmm()
import PprCmmZ()
import UniqSet
import UniqSupply
import qualified ZipCfg as G
import Maybe
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
......@@ -34,8 +38,10 @@ toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (CmmCall f res args (CmmSafe srt) CmmMayReturn : ss) =
mkCall f res args srt <*> mkStmts ss
mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
mkCall f conv res args srt <*> mkStmts ss
mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
mkUnsafeCall f res args <*> mkStmts ss
mkStmts (CmmCondBranch e l : fbranch) =
......@@ -44,7 +50,10 @@ toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args
mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
mkFinalCall f conv args
mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
mkLast (CmmJump tgt args) = mkJump tgt args
mkLast (CmmReturn ress) = mkReturn ress
......@@ -65,10 +74,14 @@ ofZgraph g = ListGraph $ swallow blocks
cscomm = "Call successors are" ++
(concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
swallow [] = []
swallow (G.Block id t : rest) = tail id [] t rest
tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
swallow (G.Block id t : rest) = tail id [] Nothing t rest
tail id prev' out (G.ZTail (CopyOut conv actuals) t) rest =
case out of
Nothing -> tail id prev' (Just (conv, actuals)) t rest
Just _ -> panic "multiple CopyOut nodes in one basic block"
tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest
tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest
tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out l rest
mid (MidNop) = CmmNop
mid (MidComment s) = CmmComment s
mid (MidAssign l r) = CmmAssign l r
......@@ -80,53 +93,65 @@ ofZgraph g = ListGraph $ swallow blocks
block' id prev'
| id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
| otherwise = BasicBlock id $ extend_block id (reverse prev')
last id prev' l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
LastBranch _ (_:_) -> panic "unrepresentable branch"
LastBranch tgt [] ->
case n of
G.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' t bs -- optimize out redundant labels
_ -> endblock (CmmBranch tgt)
LastCondBranch expr tid fid ->
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
LastBranch _ (_:_) -> panic "unrepresentable branch"
LastBranch tgt [] ->
case n of
G.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' out t bs -- optimize out redundant labels
_ -> if isNothing out then endblock (CmmBranch tgt)
else pprPanic "can't convert LGraph with pending CopyOut"
(ppr g)
LastCondBranch expr tid fid ->
if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
else
case n of
G.Block id' t : bs
| id' == fid, unique_pred id' ->
tail id (CmmCondBranch expr tid : prev') t bs
tail id (CmmCondBranch expr tid : prev') Nothing t bs
| id' == tid, unique_pred id',
Just e' <- maybeInvertCmmExpr expr ->
tail id (CmmCondBranch e' fid : prev') t bs
tail id (CmmCondBranch e' fid : prev') Nothing t bs
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
LastJump expr params -> endblock $ CmmJump expr params
LastReturn params -> endblock $ CmmReturn params
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall tgt args Nothing ->
endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
LastCall tgt args (Just k)
| G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
id' == k, unique_pred k ->
let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
in tail id (call : prev') t bs
| G.Block id' t : bs <- n, id' == k, unique_pred k ->
let (ress, srt) = findCopyIn t
call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
delayed = scomment "delayed CopyIn follows previous call"
in tail id (delayed : call : prev') t bs
| otherwise -> panic "unrepairable call"
LastJump expr params -> endblock $ CmmJump expr params
LastReturn params -> endblock $ CmmReturn params
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e cont
| Just (conv, args) <- out
-> let tgt = CmmCallee e (conv_to_cconv conv) in
case cont of
Nothing ->
endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
Just k
| G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
id' == k, unique_pred k
-> let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
in tail id (call : prev') Nothing t bs
| G.Block id' t : bs <- n, id' == k, unique_pred k
-> let (ress, srt) = findCopyIn t
call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
delayed = scomment "delayed CopyIn follows prev. call"
in tail id (delayed : call : prev') Nothing t bs
| otherwise -> panic "unrepairable call"
| otherwise -> panic "call with no CopyOut"
findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
findCopyIn (G.ZTail _ t) = findCopyIn t
findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
exit id prev' n = -- highly irregular (assertion violation?)
exit id prev' out n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
G.Block id' t : bs ->
if unique_pred id' then
tail id (scomment "went thru exit" : prev') t bs
tail id (scomment "went thru exit" : prev') out t bs
else
endblock (CmmBranch id')
conv_to_cconv (ConventionStandard c _) = c
conv_to_cconv (ConventionPrivate {}) =
panic "tried to convert private calling convention back to Cmm"
preds = zipPreds g
single_preds =
let add b single =
......@@ -141,7 +166,7 @@ ofZgraph g = ListGraph $ swallow blocks
call_succs =
let add b succs =
case G.last (G.unzip b) of
G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
G.LastOther (LastCall _ (Just id)) -> extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
_is_call_succ id = elemBlockSet id call_succs
......
......@@ -67,10 +67,10 @@ middleLiveness m = middle m
lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLiveness l env = last l
where last (LastReturn ress) = gen ress emptyUniqSet
last (LastJump e args) = gen e $ gen args emptyUniqSet
last (LastBranch id args) = gen args $ env id
last (LastCall tgt args (Just k)) = gen tgt $ gen args $ env k
last (LastCall tgt args Nothing) = gen tgt $ gen args $ emptyUniqSet
last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
where last (LastReturn ress) = gen ress emptyUniqSet
last (LastJump e args) = gen e $ gen args emptyUniqSet
last (LastBranch id args) = gen args $ env id
last (LastCall tgt (Just k)) = gen tgt $ env k
last (LastCall tgt Nothing) = gen tgt $ emptyUniqSet
last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
last (LastSwitch e tbl) = gen e $ unionManyUniqSets $ map env (catMaybes tbl)
......@@ -116,7 +116,7 @@ forward = FComp "proc-point reachability" first middle last exit
where first ProcPoint id = ReachedBy $ unitUniqSet id
first x _ = x
middle x _ = x
last _ (LastCall _ _ (Just id)) = LastOutFacts [(id, ProcPoint)]
last _ (LastCall _ (Just id)) = LastOutFacts [(id, ProcPoint)]
last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
exit _ = LastOutFacts []
......@@ -226,11 +226,11 @@ addProcPointProtocols procPoints formals g =
-- redirect the call (cf 'newblock') and set the protocol if necessary
maybe_add_call block (protos, blocks) =
case goto_end $ unzip block of
(h, LastOther (LastCall tgt args (Just k)))
(h, LastOther (LastCall tgt (Just k)))
| Just proto <- lookupBlockEnv protos k,
Just pee <- jumpsToProcPoint k
-> let newblock =
zipht h (tailOfLast (LastCall tgt args (Just pee)))
zipht h (tailOfLast (LastCall tgt (Just pee)))
changed_blocks = insertBlock newblock blocks
unchanged_blocks = insertBlock block blocks
in case lookupBlockEnv protos pee of
......@@ -254,9 +254,10 @@ addProcPointProtocols procPoints formals g =
maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
extendBlockEnv env id (Protocol c fs)
maybe_add_proto (Block id _) env | id == lg_entry g =
extendBlockEnv env id (Protocol (Argument CmmCallConv) hinted_formals)
extendBlockEnv env id (Protocol stdArgConvention hinted_formals)
maybe_add_proto _ env = env
hinted_formals = map (\x -> (x, NoHint)) formals
stdArgConvention = ConventionStandard CmmCallConv Arguments
-- | For now, following a suggestion by Ben Lippmeier, we pass all
-- live variables as arguments, hoping that a clever register
......@@ -279,7 +280,7 @@ pass_live_vars_as_args procPoints (protos, g) = (protos', g')
emptyRegSet -- XXX there's a bug lurking!
-- panic ("no liveness at block " ++ show id)
formals = map (\x->(x,NoHint)) $ uniqSetToList live
in extendBlockEnv protos id (Protocol Local formals)
in extendBlockEnv protos id (Protocol ConventionPrivate formals)
g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) }
......
......@@ -114,16 +114,16 @@ middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) liv
lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
lastDualLiveness env l = last l
where last (LastReturn ress) = changeRegs (gen ress) empty
last (LastJump e args) = changeRegs (gen e . gen args) empty
last (LastBranch id args) = changeRegs (gen args) $ env id
last (LastCall tgt args Nothing) = changeRegs (gen tgt. gen args) empty
last (LastCall tgt args (Just k)) =
where last (LastReturn ress) = changeRegs (gen ress) empty
last (LastJump e args) = changeRegs (gen e . gen args) empty
last (LastBranch id args) = changeRegs (gen args) $ env id
last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
last (LastCall tgt (Just k)) =
-- nothing can be live in registers at this point
-- only 'formals' can be in regs at this point
let live = env k in
if isEmptyUniqSet (in_regs live) then
DualLive (on_stack live) (gen tgt $ gen args emptyRegSet)
DualLive (on_stack live) (gen tgt emptyRegSet)
else
panic "live values in registers at call continuation"
last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
......@@ -265,7 +265,7 @@ middleAvail (NotSpillOrReload m) = middle m
middle (CopyOut {}) = id
lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
lastAvail _ (LastCall _ _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
......
......@@ -41,9 +41,9 @@ type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
mkNop :: CmmAGraph
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
mkCall :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph -- never returns
mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
......@@ -75,10 +75,14 @@ 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 <*>
mkMiddle (CopyIn (Result CmmCallConv) results srt)
mkFinalCall f conv actuals =
mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
mkLast (LastCall f Nothing)
mkCall f conv results actuals srt =
withFreshLabel "call successor" $ \k ->
mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
mkLast (LastCall f (Just k)) <*>
mkLabel k <*>
mkMiddle (CopyIn (ConventionStandard conv Results) results srt)
......@@ -40,7 +40,7 @@
--
module PprCmm
( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit
)
where
......@@ -572,4 +572,3 @@ pprBlockId b = ppr $ getUnique b
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
......@@ -8,25 +8,35 @@ where
import Cmm
import CmmExpr
import PprCmm()
import ForeignCall
import PprCmm
import Outputable
import qualified ZipCfgCmmRep as G
import qualified ZipCfg as Z
import CmmZipUtil
import Maybe
import UniqSet
import FastString
----------------------------------------------------------------
-- | The purpose of this function is to print a Cmm zipper graph "as if it were"
-- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
-- code are dodgy as well.
pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc
pprCmmGraphLikeCmm g = vcat (swallow blocks)
where blocks = Z.postorder_dfs g
swallow :: [G.CmmBlock] -> [SDoc]
swallow [] = []
swallow (Z.Block id t : rest) = tail id [] t rest
tail id prev' (Z.ZTail m t) rest = tail id (mid m : prev') t rest
tail id prev' (Z.ZLast Z.LastExit) rest = exit id prev' rest
tail id prev' (Z.ZLast (Z.LastOther l))rest = last id prev' l rest
swallow (Z.Block id t : rest) = tail id [] Nothing t rest
tail id prev' out (Z.ZTail (G.CopyOut conv args) t) rest =
if isJust out then panic "multiple CopyOut nodes in one basic block"
else
tail id (prev') (Just (conv, args)) t rest
tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
tail id prev' out (Z.ZLast Z.LastExit) rest = exit id prev' out rest
tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
mid (G.CopyIn _ [] _) = text "// proc point (no parameters)"
mid m@(G.CopyIn {}) = ppr m <+> text "(proc point)"
mid m = ppr m
......@@ -34,59 +44,57 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
| id == Z.lg_entry g, entry_has_no_pred =
vcat (text "<entry>" : reverse prev')
| otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
last id prev' l n =
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
G.LastBranch tgt [] ->
case n of
Z.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' t bs -- optimize out redundant labels
-> tail id prev' out t bs -- optimize out redundant labels
_ -> endblock (ppr $ CmmBranch tgt)
l@(G.LastBranch {}) -> endblock (ppr l)
l@(G.LastBranch {}) -> endblock $ with_out out l
l@(G.LastCondBranch expr tid fid) ->
let ft id = text "// fall through to " <> ppr id in
case n of
Z.Block id' t : bs
| id' == fid, False ->
tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') t bs
| id' == tid, Just e' <- maybeInvertCmmExpr expr, False ->
tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') t bs
_ -> endblock (ppr l)
l@(G.LastJump {}) -> endblock $ ppr l
l@(G.LastReturn {}) -> endblock $ ppr l
l@(G.LastSwitch {}) -> endblock $ ppr l
l@(G.LastCall _ _ Nothing) -> endblock $ ppr l
l@(G.LastCall tgt args (Just k))
| id' == fid, isNothing out ->
tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
| id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
_ -> endblock $ with_out out l
l@(G.LastJump {}) -> endblock $ with_out out l
l@(G.LastReturn {}) -> endblock $ with_out out l
l@(G.LastSwitch {}) -> endblock $ with_out out l
l@(G.LastCall _ Nothing) -> endblock $ with_out out l
l@(G.LastCall tgt (Just k))
| Z.Block id' (Z.ZTail (G.CopyIn _ ress srt) t) : bs <- n,
Just (conv, args) <- out,
id' == k ->
let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
tgt' = CmmCallee tgt (cconv_of_conv conv)
ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
in if unique_pred k then
tail id (ppcall : prev') t bs
tail id (ppcall : prev') Nothing t bs
else
endblock (ppcall)
| Z.Block id' t : bs <- n, id' == k, unique_pred k,
Just (conv, args) <- out,
Just (ress, srt) <- findCopyIn t ->
let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
tgt' = CmmCallee tgt (cconv_of_conv conv)
delayed =
ptext SLIT("// delayed CopyIn follows previous call")
in tail id (delayed : ppr call : prev') t bs
| otherwise -> endblock $ ppr l
in tail id (delayed : ppr call : prev') Nothing t bs
| otherwise -> endblock $ with_out out l
findCopyIn (Z.ZTail (G.CopyIn _ ress srt) _) = Just (ress, srt)
findCopyIn (Z.ZTail _ t) = findCopyIn t
findCopyIn (Z.ZLast _) = Nothing
exit id prev' n = -- highly irregular (assertion violation?)
exit id prev' out n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
endblock (text "// <exit>")
{-
case n of [] -> [text "<exit>"]
Z.Block id' t : bs ->
if unique_pred id' then
tail id (ptext SLIT("went thru exit") : prev') t bs
else
endblock (ppr $ CmmBranch id')
-}
case out of Nothing -> endblock (text "// <exit>")
Just (conv, args) -> endblock (ppr (G.CopyOut conv args) $$
text "// <exit>")
preds = zipPreds g
entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
Nothing -> True
......@@ -101,5 +109,21 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
else single
in Z.fold_blocks add Z.emptyBlockSet g
unique_pred id = Z.elemBlockSet id single_preds
cconv_of_conv (G.ConventionStandard conv _) = conv
cconv_of_conv (G.ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
with_out Nothing l = ptext SLIT("??no-arguments??") <+> ppr l
with_out (Just (conv, args)) l = last l
where last (G.LastCall e k) =
hcat [ptext SLIT("... = foreign "),
doubleQuotes(ppr conv), space,
ppr_target e, parens ( commafy $ map ppr args ),
ptext SLIT(" \"safe\""),
case k of Nothing -> ptext SLIT(" never returns")
Just _ -> empty,
semi ]
last l = ppr (G.CopyOut conv args) $$ ppr l
ppr_target (CmmLit lit) = pprLit lit
ppr_target fn' = parens (ppr fn')
commafy xs = hsep $ punctuate comma xs
......@@ -7,6 +7,7 @@
module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
, ValueDirection(..)
)
where
......@@ -49,15 +50,17 @@ 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]
Convention
CmmFormals
CmmFormals -- eventually [CmmKind] will be used only for foreign
-- calls and will migrate into 'Convention' (helping to
-- drain "the swamp")
C_SRT -- Static things kept alive by this block
| CopyOut Convention CmmFormals
| CopyOut Convention CmmActuals
data Last
= LastReturn CmmActuals -- Return from a function,
......@@ -71,8 +74,7 @@ data Last
-- The parameters are unused at present.
| LastCall { -- A call (native or safe foreign)
cml_target :: CmmCallTarget,
cml_actual :: CmmActuals, -- Zero or more arguments
cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
| LastCondBranch { -- conditional branch
......@@ -87,18 +89,19 @@ 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
= 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)!
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]
......@@ -123,20 +126,20 @@ instance LastNode Last where
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 (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
......@@ -159,11 +162,7 @@ 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
......@@ -238,7 +237,7 @@ pprLast stmt = (case stmt of
, parens ( commafy $ map pprHinted results )
, 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,11 +249,11 @@ pprLast stmt = (case stmt of
LastSwitch {} -> text "LastSwitch"
LastCall {} -> text "LastCall"