change the zipper representation of calls
authorNorman Ramsey <nr@eecs.harvard.edu>
Wed, 12 Sep 2007 15:38:52 +0000 (15:38 +0000)
committerNorman Ramsey <nr@eecs.harvard.edu>
Wed, 12 Sep 2007 15:38:52 +0000 (15:38 +0000)
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).

compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmLiveZ.hs
compiler/cmm/CmmProcPointZ.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/MkZipCfgCmm.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmZ.hs
compiler/cmm/ZipCfgCmmRep.hs

index 7581d81..4e319c8 100644 (file)
@@ -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
index f0c2df5..ca635c2 100644 (file)
@@ -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
index 3df8a18..00a6491 100644 (file)
@@ -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)
index 66db150..c73f016 100644 (file)
@@ -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) }
 
 
index b588c46..6195a4c 100644 (file)
@@ -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
 
 
index 6792559..9a92f6f 100644 (file)
@@ -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)
index 5f5ae55..470b325 100644 (file)
@@ -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
-
index e2fd960..18302d8 100644 (file)
@@ -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
index 0d367ad..da84f7b 100644 (file)
@@ -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("<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 ]
@@ -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 "<local>"
+pprConvention (ConventionStandard c _) = ppr c
+pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
 
 commafy :: [SDoc] -> SDoc
 commafy xs = hsep $ punctuate comma xs