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).
  

1 files changed, 58 insertions, 34 deletions

diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
index e2fd960f0c..18302d89e2 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 "<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