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 (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 = panic (msg {- ++ " in block " ++ showSDoc (ppr b) -}
  47                             ++ " in function " ++ fun_name)
  48         mkLast (CmmCall f  []     args _ CmmNeverReturns) = mkFinalCall f args
  49         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
  50         mkLast (CmmJump tgt args)          = mkJump tgt args
  51         mkLast (CmmReturn ress)            = mkReturn ress
  52         mkLast (CmmBranch tgt)             = mkBranch tgt
  53         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
  54                    panic "Call never returns but has results?!"
  55         mkLast _ = panic "fell off end of block"
  56
  57 ofZgraph :: CmmGraph -> ListGraph CmmStmt
  58 ofZgraph g = ListGraph $ swallow blocks
  59     where blocks = G.postorder_dfs g
  60           -- | the next two functions are hooks on which to hang debugging info
  61           extend_entry stmts = stmts
  62           extend_block _id stmts = stmts
  63           _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
  64           showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
  65                        concat (map (\(G.Block id _) -> " " ++ show id) blocks)
  66           cscomm = "Call successors are" ++
  67                    (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
  68           swallow [] = []
  69           swallow (G.Block id t : rest) = tail id [] t rest
  70           tail id prev' (G.ZTail m t)            rest = tail id (mid m : prev') t rest
  71           tail id prev' (G.ZLast G.LastExit)     rest = exit id prev' rest
  72           tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
  73           mid (MidNop)        = CmmNop
  74           mid (MidComment s)  = CmmComment s
  75           mid (MidAssign l r) = CmmAssign l r
  76           mid (MidStore  l r) = CmmStore  l r
  77           mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
  78           mid m@(CopyOut {})  = pcomment (ppr m)
  79           mid m@(CopyIn {})   = pcomment (ppr m <+> text "(proc point)")
  80           pcomment p = scomment $ showSDoc p
  81           block' id prev'
  82               | id == G.gr_entry g = BasicBlock id $ extend_entry    (reverse prev')
  83               | otherwise          = BasicBlock id $ extend_block id (reverse prev')
  84           last id prev' l n =
  85               let endblock stmt = block' id (stmt : prev') : swallow n in
  86               case l of
  87                 LastBranch _ (_:_) -> panic "unrepresentable branch"
  88                 LastBranch tgt [] ->
  89                     case n of
  90                       G.Block id' t : bs
  91                           | tgt == id', unique_pred id'
  92                           -> tail id prev' t bs  -- optimize out redundant labels
  93                       _ -> endblock (CmmBranch tgt)
  94                 LastCondBranch expr tid fid ->
  95                   case n of
  96                     G.Block id' t : bs
  97                       | id' == fid, unique_pred id' ->
  98                                       tail id (CmmCondBranch expr tid : prev') t bs
  99                       | id' == tid, unique_pred id',
 100                         Just e' <- maybeInvertCmmExpr expr ->
 101                                       tail id (CmmCondBranch e'   fid : prev') t bs
 102                     _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
 103                          in block' id instrs' : swallow n
 104                 LastJump expr params -> endblock $ CmmJump expr params
 105                 LastReturn params    -> endblock $ CmmReturn params
 106                 LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
 107                 LastCall tgt args Nothing ->
 108                     endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
 109                 LastCall tgt args (Just k)
 110                    | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
 111                      id' == k, unique_pred k ->
 112                          let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
 113                          in  tail id (call : prev') t bs
 114                    | G.Block id' t : bs <- n, id' == k, unique_pred k ->
 115                          let (ress, srt) = findCopyIn t
 116                              call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
 117                              delayed = scomment "delayed CopyIn follows previous call"
 118                          in  tail id (delayed : call : prev') t bs
 119                    | otherwise -> panic "unrepairable call"
 120           findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
 121           findCopyIn (G.ZTail _ t) = findCopyIn t
 122           findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
 123           exit id prev' n = -- highly irregular (assertion violation?)
 124               let endblock stmt = block' id (stmt : prev') : swallow n in
 125               case n of [] -> endblock (scomment "procedure falls off end")
 126                         G.Block id' t : bs ->
 127                             if unique_pred id' then
 128                                 tail id (scomment "went thru exit" : prev') t bs
 129                             else
 130                                 endblock (CmmBranch id')
 131           preds = zipPreds g
 132           single_preds =
 133               let add b single =
 134                     let id = G.blockId b
 135                     in  case G.lookupBlockEnv preds id of
 136                           Nothing -> single
 137                           Just s -> if sizeUniqSet s == 1 then
 138                                         G.extendBlockSet single id
 139                                     else single
 140               in  G.fold_blocks add G.emptyBlockSet g
 141           unique_pred id = G.elemBlockSet id single_preds
 142           call_succs =
 143               let add b succs =
 144                       case G.last (G.unzip b) of
 145                         G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
 146                         _ -> succs
 147               in  G.fold_blocks add emptyBlockSet g
 148           _is_call_succ id = elemBlockSet id call_succs
 149
 150 scomment :: String -> CmmStmt
 151 scomment s = CmmComment $ mkFastString s