compiler/cmm/CmmCvt.hs

   1 {-# LANGUAGE PatternGuards #-}
   2 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   3
   4 module CmmCvt
   5   ( cmmToZgraph, cmmOfZgraph )
   6 where
   7 import Cmm
   8 import CmmExpr
   9 import ZipCfgCmm
  10 import MkZipCfg
  11 import CmmZipUtil
  12 import FastString
  13 import Outputable
  14 import Panic
  15 import PprCmm()
  16 import PprCmmZ()
  17 import UniqSet
  18 import UniqSupply
  19 import qualified ZipCfg as G
  20
  21 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
  22 cmmOfZgraph :: GenCmm d h (CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
  23
  24 cmmToZgraph = cmmMapGraphM toZgraph
  25 cmmOfZgraph = cmmMapGraph  ofZgraph
  26
  27
  28 toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
  29 toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
  30 toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
  31            labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
  32   where addBlock (BasicBlock id ss) g = mkLabel id   <*> mkStmts ss <*> g
  33         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss
  34         mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
  35         mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
  36         mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
  37         mkStmts (CmmCall f res args (CmmSafe srt) CmmMayReturn : ss) =
  38                       mkCall       f res args srt <*> mkStmts ss
  39         mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
  40                       mkUnsafeCall f res args     <*> mkStmts ss
  41         mkStmts (CmmCondBranch e l : fbranch) =
  42             mkIfThenElse (mkCbranch e) (mkBranch l) (mkStmts fbranch)
  43         mkStmts (last : []) = mkLast last
  44         mkStmts []          = bad "fell off end"
  45         mkStmts (_ : _ : _) = bad "last node not at end"
  46         bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
  47         mkLast (CmmCall f  []     args _ CmmNeverReturns) = mkFinalCall f args
  48         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
  49         mkLast (CmmJump tgt args)          = mkJump tgt args
  50         mkLast (CmmReturn ress)            = mkReturn ress
  51         mkLast (CmmBranch tgt)             = mkBranch tgt
  52         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
  53                    panic "Call never returns but has results?!"
  54         mkLast _ = panic "fell off end of block"
  55
  56 ofZgraph :: CmmGraph -> ListGraph CmmStmt
  57 ofZgraph g = ListGraph $ swallow blocks
  58     where blocks = G.postorder_dfs g
  59           -- | the next two functions are hooks on which to hang debugging info
  60           extend_entry stmts = stmts
  61           extend_block _id stmts = stmts
  62           _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
  63           showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
  64                        concat (map (\(G.Block id _) -> " " ++ show id) blocks)
  65           cscomm = "Call successors are" ++
  66                    (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
  67           swallow [] = []
  68           swallow (G.Block id t : rest) = tail id [] t rest
  69           tail id prev' (G.ZTail m t)            rest = tail id (mid m : prev') t rest
  70           tail id prev' (G.ZLast G.LastExit)     rest = exit id prev' rest
  71           tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
  72           mid (MidNop)        = CmmNop
  73           mid (MidComment s)  = CmmComment s
  74           mid (MidAssign l r) = CmmAssign l r
  75           mid (MidStore  l r) = CmmStore  l r
  76           mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
  77           mid m@(CopyOut {})  = pcomment (ppr m)
  78           mid m@(CopyIn {})   = pcomment (ppr m <+> text "(proc point)")
  79           pcomment p = scomment $ showSDoc p
  80           block' id prev'
  81               | id == G.gr_entry g = BasicBlock id $ extend_entry    (reverse prev')
  82               | otherwise          = BasicBlock id $ extend_block id (reverse prev')
  83           last id prev' l n =
  84               let endblock stmt = block' id (stmt : prev') : swallow n in
  85               case l of
  86                 LastBranch _ (_:_) -> panic "unrepresentable branch"
  87                 LastBranch tgt [] ->
  88                     case n of
  89                       G.Block id' t : bs
  90                           | tgt == id', unique_pred id'
  91                           -> tail id prev' t bs  -- optimize out redundant labels
  92                       _ -> endblock (CmmBranch tgt)
  93                 LastCondBranch expr tid fid ->
  94                   case n of
  95                     G.Block id' t : bs
  96                       | id' == fid, unique_pred id' ->
  97                                       tail id (CmmCondBranch expr tid : prev') t bs
  98                       | id' == tid, unique_pred id',
  99                         Just e' <- maybeInvertCmmExpr expr ->
 100                                       tail id (CmmCondBranch e'   fid : prev') t bs
 101                     _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
 102                          in block' id instrs' : swallow n
 103                 LastJump expr params -> endblock $ CmmJump expr params
 104                 LastReturn params    -> endblock $ CmmReturn params
 105                 LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
 106                 LastCall tgt args Nothing ->
 107                     endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
 108                 LastCall tgt args (Just k)
 109                    | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
 110                      id' == k, unique_pred k ->
 111                          let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
 112                          in  tail id (call : prev') t bs
 113                    | G.Block id' t : bs <- n, id' == k, unique_pred k ->
 114                          let (ress, srt) = findCopyIn t
 115                              call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
 116                              delayed = scomment "delayed CopyIn follows previous call"
 117                          in  tail id (delayed : call : prev') t bs
 118                    | otherwise -> panic "unrepairable call"
 119           findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
 120           findCopyIn (G.ZTail _ t) = findCopyIn t
 121           findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
 122           exit id prev' n = -- highly irregular (assertion violation?)
 123               let endblock stmt = block' id (stmt : prev') : swallow n in
 124               case n of [] -> endblock (scomment "procedure falls off end")
 125                         G.Block id' t : bs ->
 126                             if unique_pred id' then
 127                                 tail id (scomment "went thru exit" : prev') t bs
 128                             else
 129                                 endblock (CmmBranch id')
 130           preds = zipPreds g
 131           single_preds =
 132               let add b single =
 133                     let id = G.blockId b
 134                     in  case G.lookupBlockEnv preds id of
 135                           Nothing -> single
 136                           Just s -> if sizeUniqSet s == 1 then
 137                                         G.extendBlockSet single id
 138                                     else single
 139               in  G.fold_blocks add G.emptyBlockSet g
 140           unique_pred id = G.elemBlockSet id single_preds
 141           call_succs =
 142               let add b succs =
 143                       case G.last (G.unzip b) of
 144                         G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
 145                         _ -> succs
 146               in  G.fold_blocks add emptyBlockSet g
 147           _is_call_succ id = elemBlockSet id call_succs
 148
 149 scomment :: String -> CmmStmt
 150 scomment s = CmmComment $ mkFastString s