compiler/cmm/CmmCvt.hs

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