-- LastBranch no longer takes parameters
-- LastJump and LastReturn no longer carry CmmActuals;
instead, those are carried by a CopyOut in the same basic block
lookup id = G.lookupBlockEnv env id `orElse` id
isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
lookup id = G.lookupBlockEnv env id `orElse` id
isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
-isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target []))))
+isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
| id /= target = Left (id,target)
isLoneBranchZ other = Right other
-- ^ An infinite loop is not a link in a branch chain!
| id /= target = Left (id,target)
isLoneBranchZ other = Right other
-- ^ An infinite loop is not a link in a branch chain!
replaceLabelsZ env = replace_eid . G.map_nodes id id last
where
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
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 (LastBranch id) = LastBranch (lookup id)
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 (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 id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
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'
case n of
G.Block id' t : bs
| tgt == id', unique_pred id'
tail id (CmmCondBranch e' fid : prev') Nothing t bs
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
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
+ LastJump expr -> endblock $ with_out out $ CmmJump expr
+ LastReturn -> endblock $ with_out out $ CmmReturn
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e cont
| Just (conv, args) <- out
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e cont
| Just (conv, args) <- out
in tail id (delayed : call : prev') Nothing t bs
| otherwise -> panic "unrepairable call"
| otherwise -> panic "call with no CopyOut"
in tail id (delayed : call : prev') Nothing t bs
| otherwise -> panic "unrepairable call"
| otherwise -> panic "call with no CopyOut"
+ with_out (Just (_conv, actuals)) f = f actuals
+ with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f [])
findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
findCopyIn (G.ZTail _ t) = findCopyIn t
findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
findCopyIn (G.ZTail _ t) = findCopyIn t
findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLiveness l env = last l
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
+ where last (LastReturn) = emptyUniqSet
+ last (LastJump e) = gen e $ emptyUniqSet
+ last (LastBranch id) = 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 (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)
let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
panic "jump out of graph"
in case t of
let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
panic "jump out of graph"
in case t of
- ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee [])))
+ ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee)))
| elemBlockSet pee procPoints -> Just pee
_ -> Nothing
init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
| elemBlockSet pee procPoints -> Just pee
_ -> Nothing
init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
lastDualLiveness env l = last l
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
+ where last (LastReturn) = empty
+ last (LastJump e) = changeRegs (gen e) empty
+ last (LastBranch id) = env id
last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
last (LastCall tgt (Just k)) =
-- nothing can be live in registers at this point
last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
last (LastCall tgt (Just k)) =
-- nothing can be live in registers at this point
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module Dataflow (
fixedpoint
module Dataflow (
fixedpoint
mkAssign l r = mkMiddle $ MidAssign l r
mkStore l r = mkMiddle $ MidStore l r
mkAssign l r = mkMiddle $ MidAssign l r
mkStore l r = mkMiddle $ MidStore l r
-mkJump e args = mkLast $ LastJump e args
mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
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
mkSwitch e tbl = mkLast $ LastSwitch e tbl
mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
+cmmArgConv, cmmResConv :: Convention
+cmmArgConv = ConventionStandard CmmCallConv Arguments
+cmmResConv = ConventionStandard CmmCallConv Arguments
+
+mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
+mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
+
mkFinalCall f conv actuals =
mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
mkLast (LastCall f Nothing)
mkFinalCall f conv actuals =
mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
mkLast (LastCall f Nothing)
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
case n of
Z.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' out t bs -- optimize out redundant labels
_ -> endblock (ppr $ CmmBranch tgt)
case n of
Z.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' out t bs -- optimize out redundant labels
_ -> endblock (ppr $ CmmBranch tgt)
- 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
l@(G.LastCondBranch expr tid fid) ->
let ft id = text "// fall through to " <> ppr id in
case n of
case k of Nothing -> ptext SLIT(" never returns")
Just _ -> empty,
semi ]
case k of Nothing -> ptext SLIT(" never returns")
Just _ -> empty,
semi ]
+ last (G.LastReturn) = ppr (CmmReturn args)
+ last (G.LastJump e) = ppr (CmmJump e args)
last l = ppr (G.CopyOut conv args) $$ ppr l
ppr_target (CmmLit lit) = pprLit lit
ppr_target fn' = parens (ppr fn')
last l = ppr (G.CopyOut conv args) $$ ppr l
ppr_target (CmmLit lit) = pprLit lit
ppr_target fn' = parens (ppr fn')
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
- , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
- , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
+ , CmmCallTarget(..), CmmActuals, CmmFormals
+ , CmmStmt(CmmSwitch) -- imported in order to call ppr
import Outputable
import Prelude hiding (zip, unzip, last)
import Outputable
import Prelude hiding (zip, unzip, last)
+----------------------------------------------------------------------
+----- Type synonyms and definitions
+
type CmmGraph = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
type CmmBlock = Block Middle Last
type CmmGraph = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
type CmmBlock = Block Middle Last
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
- | CopyIn -- Move parameters or results from conventional locations to registers
- -- Note [CopyIn invariant]
+ | CopyIn -- Move incoming parameters or results from conventional
+ -- locations to registers. Note [CopyIn invariant]
Convention
CmmFormals -- eventually [CmmKind] will be used only for foreign
-- calls and will migrate into 'Convention' (helping to
Convention
CmmFormals -- eventually [CmmKind] will be used only for foreign
-- calls and will migrate into 'Convention' (helping to
+ -- drain "the swamp"), leaving this as [LocalReg]
C_SRT -- Static things kept alive by this block
C_SRT -- Static things kept alive by this block
| CopyOut Convention CmmActuals
| CopyOut Convention CmmActuals
+ -- Move outgoing parameters or results from registers to
+ -- conventional locations. Every 'LastReturn',
+ -- 'LastJump', or 'LastCall' must be dominated by a
+ -- matching 'CopyOut' in the same basic block.
+ -- As above, '[CmmKind]' will migrate into the foreign calling
+ -- convention, leaving the actuals as '[CmmExpr]'.
- = LastReturn CmmActuals -- Return from a function,
- -- with these return values.
-
- | LastJump CmmExpr CmmActuals
- -- Tail call to another procedure
-
- | LastBranch BlockId CmmFormalsWithoutKinds
- -- To another block in the same procedure
- -- The parameters are unused at present.
-
- | LastCall { -- A call (native or safe foreign)
- cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
- cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
+ = LastBranch BlockId -- Goto another block in the same procedure
| LastCondBranch { -- conditional branch
cml_pred :: CmmExpr,
cml_true, cml_false :: BlockId
}
| LastCondBranch { -- conditional branch
cml_pred :: CmmExpr,
cml_true, cml_false :: BlockId
}
+ | LastReturn -- Return from a function; values in a previous CopyOut node
+
+ | LastJump CmmExpr -- Tail call to another procedure; args in a CopyOut node
+
+ | LastCall { -- A call (native or safe foreign)
+ cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
+ cml_cont :: Maybe BlockId } -- BlockId of continuation, if call returns
+
| LastSwitch CmmExpr [Maybe BlockId] -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
| LastSwitch CmmExpr [Maybe BlockId] -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
data Convention
= ConventionStandard CCallConv ValueDirection
| ConventionPrivate
data Convention
= 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)!
+ -- 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)!
+ -- This data type eventually to be extended to record the convention.
+
deriving Eq
data ValueDirection = Arguments | Results
deriving Eq
data ValueDirection = Arguments | Results
{-
Note [CopyIn invariant]
~~~~~~~~~~~~~~~~~~~~~~~
{-
Note [CopyIn invariant]
~~~~~~~~~~~~~~~~~~~~~~~
-In principle, CopyIn ought to be a First node, but in practice, the
+One might wish for CopyIn 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
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.
+placement of CopyIn a dynamic invariant; it should normally be the first
+Middle node in the basic block in which it occurs.
+----------------------------------------------------------------------
+----- Instance declarations for control flow
+
instance HavingSuccessors Last where
succs = cmmSuccs
fold_succs = fold_cmm_succs
instance LastNode Last where
instance HavingSuccessors Last where
succs = cmmSuccs
fold_succs = fold_cmm_succs
instance LastNode Last where
- mkBranchNode id = LastBranch id []
- isBranchNode (LastBranch _ []) = True
+ mkBranchNode id = LastBranch id
+ isBranchNode (LastBranch _) = True
- branchNodeTarget (LastBranch id []) = id
+ branchNodeTarget (LastBranch id) = id
branchNodeTarget _ = panic "asked for target of non-branch"
cmmSuccs :: Last -> [BlockId]
cmmSuccs (LastReturn {}) = []
cmmSuccs (LastJump {}) = []
branchNodeTarget _ = panic "asked for target of non-branch"
cmmSuccs :: Last -> [BlockId]
cmmSuccs (LastReturn {}) = []
cmmSuccs (LastJump {}) = []
-cmmSuccs (LastBranch id _) = [id]
+cmmSuccs (LastBranch id) = [id]
cmmSuccs (LastCall _ (Just id)) = [id]
cmmSuccs (LastCall _ Nothing) = []
cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
cmmSuccs (LastCall _ (Just id)) = [id]
cmmSuccs (LastCall _ Nothing) = []
cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
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 :: (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 (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
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 declarations for prettyprinting (avoids recursive imports)
instance Outputable Middle where
ppr s = pprMiddle s
instance Outputable Middle where
ppr s = pprMiddle s
ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
CopyOut conv args ->
ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
CopyOut conv args ->
- if null args then empty
- else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
- parens (commafy (map pprHinted args))
+ ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+>
+ parens (commafy (map pprHinted args))
-- // text
MidComment s -> text "//" <+> ftext s
-- // text
MidComment s -> text "//" <+> ftext s
pprLast :: Last -> SDoc
pprLast stmt = (case stmt of
pprLast :: Last -> SDoc
pprLast stmt = (case stmt of
- LastBranch ident args -> genBranchWithArgs ident args
+ LastBranch ident -> ptext SLIT("goto") <+> ppr ident <> semi
LastCondBranch expr t f -> genFullCondBranch expr t f
LastCondBranch expr t f -> genFullCondBranch expr t f
- LastJump expr params -> ppr $ CmmJump expr params
- LastReturn results -> hcat [ ptext SLIT("return"), space
- , parens ( commafy $ map pprHinted results )
- , semi ]
+ LastJump expr -> hcat [ ptext SLIT("jump"), space, pprFun expr
+ , ptext SLIT("(...)"), semi]
+ LastReturn -> hcat [ ptext SLIT("return"), space
+ , ptext SLIT("(...)"), semi]
LastSwitch arg ids -> ppr $ CmmSwitch arg ids
LastCall tgt k -> genBareCall tgt k
) <>
LastSwitch arg ids -> ppr $ CmmSwitch arg ids
LastCall tgt k -> genBareCall tgt k
) <>
genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
genBareCall fn k =
genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
genBareCall fn k =
- hcat [ ptext SLIT("foreign"), space
- , doubleQuotes(ptext SLIT("<convention from CopyOut>")), space
- , target fn, parens ( ptext SLIT("<parameters from CopyOut>") ), space
+ hcat [ ptext SLIT("call"), space
+ , pprFun fn, ptext SLIT("(...)"), space
, case k of Nothing -> ptext SLIT("never returns")
Just k -> ptext SLIT("returns to") <+> ppr k
, semi ]
where
, 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')
-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
+pprFun :: CmmExpr -> SDoc
+pprFun f@(CmmLit _) = ppr f
+pprFun f = parens (ppr f)
genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
genFullCondBranch expr t f =
genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
genFullCondBranch expr t f =