CmmCvt.hs 5.76 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
Ian Lynagh's avatar
Ian Lynagh committed
2
-- ToDo: remove -fno-warn-incomplete-patterns
3
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
4 5

module CmmCvt
6
  ( cmmOfZgraph )
7
where
8

9
import BlockId
10
import Cmm
11
import CmmUtils
12 13
import qualified OldCmm as Old
import OldPprCmm ()
14

15
import Hoopl
16 17
import Data.Maybe
import Maybes
18
import Outputable
19

Simon Peyton Jones's avatar
Simon Peyton Jones committed
20
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
21
cmmOfZgraph tops = map mapTop tops
22
  where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
23
        mapTop (CmmData s ds) = CmmData s ds
24

25 26
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
add_hints args hints = zipWith Old.CmmHinted args hints
27

28 29 30 31 32 33
get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
                             arg_hints ++ repeat NoHint)
  where (res_hints, arg_hints) = callishMachOpHints op
get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
  = (res_hints, arg_hints)
34

35
cmm_target :: ForeignTarget -> Old.CmmCallTarget
Ian Lynagh's avatar
Ian Lynagh committed
36
cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
37 38 39 40 41
cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc

get_ret :: ForeignTarget -> CmmReturnInfo
get_ret (PrimTarget _) = CmmMayReturn
get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89

ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
  -- We catenated some blocks in the conversion process,
  -- because of the CmmCondBranch -- the machine code does not have
  -- 'jump here or there' instruction, but has 'jump if true' instruction.
  -- As OldCmm has the same instruction, so we use it.
  -- When we are doing this, we also catenate normal goto-s (it is for free).

  -- Exactly, we catenate blocks with nonentry labes, that are
  --   a) mentioned exactly once as a successor
  --   b) any of 1) are a target of a goto
  --             2) are false branch target of a conditional jump
  --             3) are true branch target of a conditional jump, and
  --                  the false branch target is a successor of at least 2 blocks
  --                  and the condition can be inverted
  -- The complicated rule 3) is here because we need to assign at most one
  -- catenable block to a CmmCondBranch.
    where preds :: BlockEnv [CmmNode O C]
          preds = mapFold add mapEmpty $ toBlockMap g
            where add block env = foldr (add' $ lastNode block) env (successors block)
                  add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
                  add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env

          to_be_catenated :: BlockId -> Bool
          to_be_catenated id | id == g_entry g = False
                             | Just [CmmBranch _] <- mapLookup id preds = True
                             | Just [CmmCondBranch _ _ f] <- mapLookup id preds
                             , f == id = True
                             | Just [CmmCondBranch e t f] <- mapLookup id preds
                             , t == id
                             , Just (_:_:_) <- mapLookup f preds
                             , Just _ <- maybeInvertCmmExpr e = True
          to_be_catenated _ = False

          convert_block block | to_be_catenated (entryLabel block) = Nothing
          convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
            where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
                  first (CmmEntry bid) stmts = Old.BasicBlock bid stmts

                  middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
                  middle node stmts = stmt : stmts
                    where stmt :: Old.CmmStmt
                          stmt = case node of
                            CmmComment s                                   -> Old.CmmComment s
                            CmmAssign l r                                  -> Old.CmmAssign l r
                            CmmStore  l r                                  -> Old.CmmStore  l r
                            CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
90
                            CmmUnsafeForeignCall target ress args          ->
91
                              Old.CmmCall (cmm_target target)
92 93 94 95 96 97
                                          (add_hints ress res_hints)
                                          (add_hints args arg_hints)
                                          (get_ret target)
                                  where
                                     (res_hints, arg_hints) = get_hints target

98 99 100 101 102 103 104 105 106 107 108 109 110

                  last :: CmmNode O C -> () -> [Old.CmmStmt]
                  last node _ = stmts
                    where stmts :: [Old.CmmStmt]
                          stmts = case node of
                            CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
                                          | otherwise -> [Old.CmmBranch tgt]
                            CmmCondBranch expr tid fid
                              | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
                              | to_be_catenated tid
                              , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
                              | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
                            CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
111
                            -- ToDo: STG Live
112
                            CmmCall e _ r _ _ _ -> [Old.CmmJump e r]
113 114 115 116
                            CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
                          tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
                                          Old.BasicBlock _ stmts -> stmts
                            where Just block = mapLookup bid $ toBlockMap g
117