compiler/cmm/CmmCvt.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 module CmmCvt
   4   ( cmmToZgraph, cmmOfZgraph )
   5 where
   6
   7 import BlockId
   8 import ClosureInfo (C_SRT(..))
   9 import Cmm
  10 import CmmExpr
  11 import MkZipCfgCmm hiding (CmmGraph)
  12 import ZipCfgCmmRep -- imported for reverse conversion
  13 import CmmZipUtil
  14 import ForeignCall
  15 import PprCmm()
  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 toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph
  37 toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph
  38 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
  39            let (offset, entry) = mkEntry id Native args in
  40            labelAGraph id offset $
  41               entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
  42   where addBlock (BasicBlock id ss) g = mkLabel id Nothing  <*> 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 (map hintlessCmm res) (map hintlessCmm 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 (convert_target f res args)
  53                         (strip_hints res) (strip_hints args) <*> mkStmts ss
  54         mkStmts (CmmCondBranch e l : fbranch) =
  55             mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
  56         mkStmts (last : []) = mkLast last
  57         mkStmts []          = bad "fell off end"
  58         mkStmts (_ : _ : _) = bad "last node not at end"
  59         bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
  60         mkLast (CmmCall (CmmCallee f conv) []     args _ CmmNeverReturns) =
  61             mkFinalCall f conv $ map hintlessCmm args
  62         mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
  63             panic "Call to CmmPrim never returns?!"
  64         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
  65         -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
  66         -- CONVENTIONS ARE HONORED?
  67         mkLast (CmmJump tgt args)          = mkJump   tgt $ map hintlessCmm args
  68         mkLast (CmmReturn ress)            = mkReturn $ map hintlessCmm ress
  69         mkLast (CmmBranch tgt)             = mkBranch tgt
  70         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
  71                    panic "Call never returns but has results?!"
  72         mkLast _ = panic "fell off end of block"
  73
  74 strip_hints :: [CmmHinted a] -> [a]
  75 strip_hints = map hintlessCmm
  76
  77 convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
  78 convert_target (CmmCallee e cc) ress  args  = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
  79 convert_target (CmmPrim op)        _ress _args = PrimTarget op
  80
  81 add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
  82 add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
  83
  84 get_hints :: Convention -> ValueDirection -> [ForeignHint]
  85 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
  86 get_hints (Foreign (ForeignConvention _ _ hints)) Results   = hints
  87 get_hints _other_conv                             _vd       = repeat NoHint
  88
  89 get_conv :: MidCallTarget -> Convention
  90 get_conv (PrimTarget _)       = Native
  91 get_conv (ForeignTarget _ fc) = Foreign fc
  92
  93 cmm_target :: MidCallTarget -> CmmCallTarget
  94 cmm_target (PrimTarget op) = CmmPrim op
  95 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
  96
  97 ofZgraph :: CmmGraph -> ListGraph CmmStmt
  98 ofZgraph g = ListGraph $ swallow blocks
  99     where blocks = G.postorder_dfs g
 100           -- | the next two functions are hooks on which to hang debugging info
 101           extend_entry stmts = stmts
 102           extend_block _id stmts = stmts
 103           _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
 104           showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
 105                        concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
 106           cscomm = "Call successors are" ++
 107                    (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
 108           swallow [] = []
 109           swallow (G.Block id _ t : rest) = tail id [] t rest
 110           tail id prev' (G.ZTail m t)             rest = tail id (mid m : prev') t rest
 111           tail id prev' (G.ZLast G.LastExit)      rest = exit id prev' rest
 112           tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
 113           mid (MidComment s)  = CmmComment s
 114           mid (MidAssign l r) = CmmAssign l r
 115           mid (MidStore  l r) = CmmStore  l r
 116           mid (MidUnsafeCall target ress args)
 117                 = CmmCall (cmm_target target)
 118                           (add_hints conv Results   ress)
 119                           (add_hints conv Arguments args)
 120                           CmmUnsafe CmmMayReturn
 121                 where
 122                   conv = get_conv target
 123           mid m@(MidAddToContext {}) = pcomment (ppr m)
 124           pcomment p = scomment $ showSDoc p
 125           block' id prev'
 126               | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')
 127               | otherwise          = BasicBlock id $ extend_block id (reverse prev')
 128           last id prev' l n =
 129             let endblock stmt = block' id (stmt : prev') : swallow n in
 130             case l of
 131               LastBranch tgt ->
 132                   case n of
 133                     -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
 134                     --G.Block id' _ t : bs
 135                     --    | tgt == id', unique_pred id'
 136                     --    -> tail id prev' t bs -- optimize out redundant labels
 137                     _ -> endblock (CmmBranch tgt)
 138               LastCondBranch expr tid fid ->
 139                   case n of
 140                     G.Block id' _ t : bs
 141                       | id' == fid, unique_pred id' ->
 142                                  tail id (CmmCondBranch expr tid : prev') t bs
 143                       | id' == tid, unique_pred id',
 144                         Just e' <- maybeInvertCmmExpr expr ->
 145                                  tail id (CmmCondBranch e'   fid : prev') t bs
 146                     _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
 147                          in block' id instrs' : swallow n
 148               LastJump expr _      -> endblock $ CmmJump expr []
 149               LastReturn _         -> endblock $ CmmReturn []
 150               LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
 151               LastCall e cont _ ->
 152                 let tgt = CmmCallee e CCallConv in
 153                 case cont of
 154                   Nothing ->
 155                       endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns
 156                   Just _ ->
 157                        endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn
 158           exit id prev' n = -- highly irregular (assertion violation?)
 159               let endblock stmt = block' id (stmt : prev') : swallow n in
 160               case n of [] -> endblock (scomment "procedure falls off end")
 161                         G.Block id' _ t : bs ->
 162                             if unique_pred id' then
 163                                 tail id (scomment "went thru exit" : prev') t bs
 164                             else
 165                                 endblock (CmmBranch id')
 166           preds = zipPreds g
 167           single_preds =
 168               let add b single =
 169                     let id = G.blockId b
 170                     in  case lookupBlockEnv preds id of
 171                           Nothing -> single
 172                           Just s -> if sizeUniqSet s == 1 then
 173                                         extendBlockSet single id
 174                                     else single
 175               in  G.fold_blocks add emptyBlockSet g
 176           unique_pred id = elemBlockSet id single_preds
 177           call_succs =
 178               let add b succs =
 179                       case G.last (G.unzip b) of
 180                         G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id
 181                         _ -> succs
 182               in  G.fold_blocks add emptyBlockSet g
 183           _is_call_succ id = elemBlockSet id call_succs
 184
 185 scomment :: String -> CmmStmt
 186 scomment s = CmmComment $ mkFastString s