compiler/cmm/CmmCvt.hs

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