compiler/cmm/CmmCvt.hs

   1 {-# LANGUAGE GADTs #-}
   2 -- ToDo: remove
   3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   4
   5 module CmmCvt
   6   ( cmmToZgraph, cmmOfZgraph )
   7 where
   8
   9 import BlockId
  10 import Cmm
  11 import CmmDecl
  12 import CmmExpr
  13 import MkGraph
  14 import qualified OldCmm as Old
  15 import OldPprCmm ()
  16
  17 import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
  18 import Control.Monad
  19 import Data.Maybe
  20 import Maybes
  21 import Outputable
  22 import UniqSupply
  23
  24 cmmToZgraph :: Old.Cmm -> UniqSM Cmm
  25 cmmOfZgraph :: Cmm     -> Old.Cmm
  26
  27 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
  28   where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
  29           do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
  30              return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
  31         mapTop (CmmData s ds) = return $ CmmData s ds
  32 cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
  33   where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
  34         mapTop (CmmData s ds) = CmmData s ds
  35
  36 toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
  37 toZgraph _ (Old.ListGraph []) =
  38   do g <- lgraphOfAGraph emptyAGraph
  39      return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
  40 toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
  41            let (offset, entry) = mkCallEntry NativeNodeCall [] in
  42            do g <- labelAGraph id $
  43                      entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
  44               return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
  45   where addBlock (Old.BasicBlock id ss) g =
  46           mkLabel id <*> mkStmts ss <*> g
  47         updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
  48         mkStmts (Old.CmmNop        : ss)  = mkNop        <*> mkStmts ss
  49         mkStmts (Old.CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
  50         mkStmts (Old.CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
  51         mkStmts (Old.CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
  52         mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
  53             mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
  54             <*> mkStmts ss
  55               where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
  56         mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
  57             panic "safe call to a primitive CmmPrim CallishMachOp"
  58         mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
  59                       mkUnsafeCall (convert_target f res args)
  60                         (strip_hints res) (strip_hints args)
  61                       <*> mkStmts ss
  62         mkStmts (Old.CmmCondBranch e l : fbranch) =
  63             mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
  64         mkStmts (last : []) = mkLast last
  65         mkStmts []          = bad "fell off end"
  66         mkStmts (_ : _ : _) = bad "last node not at end"
  67         bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
  68         mkLast (Old.CmmCall (Old.CmmCallee f conv) []     args _ Old.CmmNeverReturns) =
  69             mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
  70         mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
  71             panic "Call to CmmPrim never returns?!"
  72         mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
  73         -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
  74         -- CONVENTIONS ARE HONORED?
  75         mkLast (Old.CmmJump tgt args)          = mkJump   tgt (map Old.hintlessCmm args) updfr_sz
  76         mkLast (Old.CmmReturn ress)            =
  77           mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
  78         mkLast (Old.CmmBranch tgt)             = mkBranch tgt
  79         mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
  80                    panic "Call never returns but has results?!"
  81         mkLast _ = panic "fell off end of block"
  82
  83 strip_hints :: [Old.CmmHinted a] -> [a]
  84 strip_hints = map Old.hintlessCmm
  85
  86 convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget
  87 convert_target (Old.CmmCallee e cc) ress  args  = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
  88 convert_target (Old.CmmPrim op)    _ress _args = PrimTarget op
  89
  90 data ValueDirection = Arguments | Results
  91
  92 add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
  93 add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
  94
  95 get_hints :: Convention -> ValueDirection -> [ForeignHint]
  96 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
  97 get_hints (Foreign (ForeignConvention _ _ hints)) Results   = hints
  98 get_hints _other_conv                             _vd       = repeat NoHint
  99
 100 get_conv :: ForeignTarget -> Convention
 101 get_conv (PrimTarget _)       = NativeNodeCall -- JD: SUSPICIOUS
 102 get_conv (ForeignTarget _ fc) = Foreign fc
 103
 104 cmm_target :: ForeignTarget -> Old.CmmCallTarget
 105 cmm_target (PrimTarget op) = Old.CmmPrim op
 106 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
 107
 108 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
 109 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
 110   -- We catenated some blocks in the conversion process,
 111   -- because of the CmmCondBranch -- the machine code does not have
 112   -- 'jump here or there' instruction, but has 'jump if true' instruction.
 113   -- As OldCmm has the same instruction, so we use it.
 114   -- When we are doing this, we also catenate normal goto-s (it is for free).
 115
 116   -- Exactly, we catenate blocks with nonentry labes, that are
 117   --   a) mentioned exactly once as a successor
 118   --   b) any of 1) are a target of a goto
 119   --             2) are false branch target of a conditional jump
 120   --             3) are true branch target of a conditional jump, and
 121   --                  the false branch target is a successor of at least 2 blocks
 122   --                  and the condition can be inverted
 123   -- The complicated rule 3) is here because we need to assign at most one
 124   -- catenable block to a CmmCondBranch.
 125     where preds :: BlockEnv [CmmNode O C]
 126           preds = mapFold add mapEmpty $ toBlockMap g
 127             where add block env = foldr (add' $ lastNode block) env (successors block)
 128                   add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
 129                   add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
 130
 131           to_be_catenated :: BlockId -> Bool
 132           to_be_catenated id | id == g_entry g = False
 133                              | Just [CmmBranch _] <- mapLookup id preds = True
 134                              | Just [CmmCondBranch _ _ f] <- mapLookup id preds
 135                              , f == id = True
 136                              | Just [CmmCondBranch e t f] <- mapLookup id preds
 137                              , t == id
 138                              , Just (_:_:_) <- mapLookup f preds
 139                              , Just _ <- maybeInvertCmmExpr e = True
 140           to_be_catenated _ = False
 141
 142           convert_block block | to_be_catenated (entryLabel block) = Nothing
 143           convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
 144             where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
 145                   first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
 146
 147                   middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
 148                   middle node stmts = stmt : stmts
 149                     where stmt :: Old.CmmStmt
 150                           stmt = case node of
 151                             CmmComment s                                   -> Old.CmmComment s
 152                             CmmAssign l r                                  -> Old.CmmAssign l r
 153                             CmmStore  l r                                  -> Old.CmmStore  l r
 154                             CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
 155                             CmmUnsafeForeignCall target ress args          ->
 156                               Old.CmmCall (cmm_target target)
 157                                           (add_hints (get_conv target) Results   ress)
 158                                           (add_hints (get_conv target) Arguments args)
 159                                           Old.CmmUnsafe Old.CmmMayReturn
 160
 161                   last :: CmmNode O C -> () -> [Old.CmmStmt]
 162                   last node _ = stmts
 163                     where stmts :: [Old.CmmStmt]
 164                           stmts = case node of
 165                             CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
 166                                           | otherwise -> [Old.CmmBranch tgt]
 167                             CmmCondBranch expr tid fid
 168                               | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
 169                               | to_be_catenated tid
 170                               , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
 171                               | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
 172                             CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
 173                             CmmCall e _ _ _ _ -> [Old.CmmJump e []]
 174                             CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
 175                           tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
 176                                           Old.BasicBlock _ stmts -> stmts
 177                             where Just block = mapLookup bid $ toBlockMap g