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
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)
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) =
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
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
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 =
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
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)
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 []
-- 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
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
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) }
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)
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
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
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)
--
module PprCmm
- ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
+ ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit
)
where
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
-
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
| 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
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
module ZipCfgCmmRep
( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
+ , ValueDirection(..)
)
where
| 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,
-- 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
-- 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]
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
ppr = pprLgraph
debugPpr :: Bool
-#ifdef DEBUG
-debugPpr = True
-#else
-debugPpr = False
-#endif
+debugPpr = debugIsOn
pprMiddle :: Middle -> SDoc
pprMiddle 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 " //" <+>
LastSwitch {} -> text "LastSwitch"
LastCall {} -> text "LastCall"
-genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
-genCall (CmmCallee fn cconv) args k =
+genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
+genBareCall fn k =
hcat [ ptext SLIT("foreign"), space
- , doubleQuotes(ppr cconv), space
- , target fn, parens ( commafy $ map pprHinted args ), space
+ , doubleQuotes(ptext SLIT("<convention from CopyOut>")), space
+ , target fn, parens ( ptext SLIT("<parameters from CopyOut>") ), space
, case k of Nothing -> ptext SLIT("never returns")
Just k -> ptext SLIT("returns to") <+> ppr k
, semi ]
target t@(CmmLit _) = ppr t
target fn' = parens (ppr fn')
-genCall (CmmPrim op) args k =
- hcat [ text "%", text (show op), parens ( commafy $ map pprHinted 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 <+>
]
pprConvention :: Convention -> SDoc
-pprConvention (Argument c) = ppr c
-pprConvention (Result c) = ppr c
-pprConvention Local = text "<local>"
+pprConvention (ConventionStandard c _) = ppr c
+pprConvention (ConventionPrivate {} ) = text "<private-convention>"
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
projects / ghc-hetmet.git / commitdiff