From: Norman Ramsey Date: Wed, 12 Sep 2007 15:38:52 +0000 (+0000) Subject: change the zipper representation of calls X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b822c1e46cd64d1dba23fbab0f775b731bf0f12b 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). --- diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 7581d81..4e319c8 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -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 diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index f0c2df5..ca635c2 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -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 diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 3df8a18..00a6491 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -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) diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 66db150..c73f016 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -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) } diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index b588c46..6195a4c 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -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 diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 6792559..9a92f6f 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -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) diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 5f5ae55..470b325 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -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 - diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index e2fd960..18302d8 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -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 "" : 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 "// ") -{- - case n of [] -> [text ""] - 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 "// ") + Just (conv, args) -> endblock (ppr (G.CopyOut conv args) $$ + text "// ") 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 diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 0d367ad..da84f7b 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -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" -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("")), space + , target fn, parens ( ptext SLIT("") ), space , case k of Nothing -> ptext SLIT("never returns") Just k -> ptext SLIT("returns to") <+> ppr k , semi ] @@ -262,11 +261,6 @@ genCall (CmmCallee fn cconv) args k = 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 <+> @@ -283,9 +277,8 @@ genFullCondBranch expr t f = ] pprConvention :: Convention -> SDoc -pprConvention (Argument c) = ppr c -pprConvention (Result c) = ppr c -pprConvention Local = text "" +pprConvention (ConventionStandard c _) = ppr c +pprConvention (ConventionPrivate {} ) = text "" commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs