compiler/cmm/CmmCPS.hs

   1 module CmmCPS (cmmCPS) where
   2
   3 #include "HsVersions.h"
   4
   5 import Cmm
   6 import CmmLint
   7 import PprCmm
   8
   9 import Dataflow (cmmLivenessComment, cmmLiveness, CmmLive)
  10
  11 import MachOp
  12 import ForeignCall
  13 import CLabel
  14
  15 import DynFlags
  16 import ErrUtils
  17 import Maybes
  18 import Outputable
  19 import UniqSupply
  20 import UniqFM
  21 import UniqSet
  22 import Unique
  23
  24 import Monad
  25 import IO
  26
  27 --------------------------------------------------------------------------------
  28 -- Monad for the CPSer
  29 -- Contains:
  30 --  * State for the uniqSupply
  31
  32 data CPSState = CPSState { cps_uniqs :: UniqSupply }
  33
  34 data CPS a = CPS { runCPS :: CPSState -> (CPSState, a) }
  35
  36 instance Monad CPS where
  37   return a = CPS $ \s -> (s, a)
  38   (CPS m) >>= f = CPS $ \s ->
  39     let (s', m') = m s
  40     in runCPS (f m') s'
  41
  42 --------------------------------------------------------------------------------
  43 -- Utility functions
  44
  45 getState = CPS $ \s -> (s, s)
  46 putState s = CPS $ \_ -> (s, ())
  47
  48 newLabelCPS = do
  49   state <- getState
  50   let (us1, us2) = splitUniqSupply (cps_uniqs state)
  51   putState $ state { cps_uniqs = us1 }
  52   return $ BlockId (uniqFromSupply us2)
  53
  54 mapMCmmTop :: (Monad m) => (CmmTop -> m [CmmTop]) -> Cmm -> m Cmm
  55 mapMCmmTop f (Cmm xs) = liftM Cmm $ liftM concat $ mapM f xs
  56
  57 --------------------------------------------------------------------------------
  58
  59 -- The format for the call to a continuation
  60 -- The fst is the arguments that must be passed to the continuation
  61 -- by the continuation's caller.
  62 -- The snd is the live values that must be saved on stack.
  63 -- A Nothing indicates an ignored slot.
  64 -- The head of each list is the stack top or the first parameter.
  65
  66 -- The format for live values for a particular continuation
  67 -- All on stack for now.
  68 -- Head element is the top of the stack (or just under the header).
  69 -- Nothing means an empty slot.
  70 -- Future possibilities include callee save registers (i.e. passing slots in register)
  71 -- and heap memory (not sure if that's usefull at all though, but it may
  72 -- be worth exploring the design space).
  73
  74 data CPSBlockInfo
  75   = ControlBlock -- Consider whether a proc-point might want arguments on stack
  76   | ContinuationBlock [(CmmReg,MachHint)] {- params -}
  77
  78 type ContinuationFormat = [Maybe LocalReg] -- TODO: consider params as part of format
  79
  80 -- A block can be a continuation of a call
  81 -- A block can be a continuation of another block (w/ or w/o joins)
  82 -- A block can be an entry to a function
  83
  84 type CmmParam = [(CmmReg,MachHint)]
  85
  86 -- For now just select the continuation orders in the order they are in the set with no gaps
  87 selectContinuationFormat :: UniqFM {-BlockId-} CmmParam -> UniqFM {-BlockId-} CmmLive -> UniqFM {-BlockId-} ContinuationFormat
  88 selectContinuationFormat param live = mapUFM (map Just . uniqSetToList) live
  89
  90 transformReturn block_infos formats (BasicBlock ident stmts) =
  91   case last $ init stmts of
  92     CmmReturn arguments ->
  93         BasicBlock ident $ (init $ init stmts) ++
  94                          [CmmJump (CmmReg spReg) arguments]
  95     -- TODO: tail calls
  96     -- TODO: return direct at the end of a block
  97     _ -> BasicBlock ident stmts
  98
  99 destructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} ContinuationFormat -> CmmBasicBlock -> CmmBasicBlock
 100 destructContinuation block_infos formats (BasicBlock ident stmts) =
 101   case info of
 102     ControlBlock -> BasicBlock ident stmts
 103     ContinuationBlock _ -> BasicBlock ident (unpack_continuation ++ stmts)
 104   where
 105   info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 106   format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 107   unpack_continuation = CmmAssign spReg (CmmRegOff spReg frame_size) :
 108                         [CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (i*stack_slot_size)) (localRegRep reg))
 109                          | (i, Just reg) <- zip [1..] format]
 110   frame_size = stack_header_size + stack_slot_size * (length format)
 111   stack_header_size = stack_slot_size -- TODO: check if this could be different than stack_slot_size
 112   stack_slot_size = 4 -- TODO: find actual variables to be used instead of this
 113
 114 constructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} ContinuationFormat -> CmmBasicBlock -> CmmBasicBlock
 115 constructContinuation block_infos formats (BasicBlock ident stmts) =
 116   case last $ init stmts of
 117     -- TODO: global_saves
 118     --CmmCall (CmmForeignCall target CmmCallConv) results arguments (Just []) -> --TODO: handle globals
 119     CmmCall (CmmForeignCall target CmmCallConv) results arguments _ ->
 120         BasicBlock ident $
 121                    init (init stmts) ++
 122                    pack_continuation ++
 123                    [CmmJump target arguments]
 124     CmmCall target results arguments _ -> panic "unimplemented CmmCall"
 125     _ -> BasicBlock ident $ (init stmts) ++ build_block_branch
 126   where
 127   info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
 128   format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
 129   next_block = case last stmts of
 130     CmmBranch next -> next
 131     -- TODO: blocks with jump at end
 132     -- TODO: blocks with return at end
 133     _ -> panic "basic block without a branch at the end (unimplemented)"
 134   next_block_as_proc_expr = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next_block
 135   pack_continuation = CmmAssign spReg (CmmRegOff spReg (-frame_size)) :
 136                        CmmStore (CmmReg spReg) next_block_as_proc_expr :
 137                        [CmmStore (CmmRegOff spReg (i*stack_slot_size)) (CmmReg $ CmmLocal reg)
 138                         | (i, Just reg) <- zip [1..] format]
 139   frame_size = stack_header_size + stack_slot_size * (length format)
 140   stack_header_size = stack_slot_size -- TODO: check if this could be different than stack_slot_size (e.g. fixedHdrSize depends on PAR and GRAN)
 141   stack_slot_size = 4 -- TODO: find actual variables to be used instead of this (e.g. cgRepSizeW)
 142   block_needs_call = True -- TODO: use a table (i.e. proc-point)
 143   build_block_branch =
 144     if block_needs_call
 145        then [CmmJump next_block_as_proc_expr [] {- TODO: pass live -}] {- NOTE: a block can never be both a continuation and a controll block -}
 146        else [CmmBranch next_block]
 147
 148 -- TODO: TBD when to adjust the stack
 149
 150 cpsProc :: CmmTop -> CPS [CmmTop]
 151 cpsProc x@(CmmData _ _) = return [x]
 152 cpsProc x@(CmmProc info_table ident params blocks) = do
 153   broken_blocks <- liftM concat $ mapM breakBlock blocks
 154   let live = cmmLiveness (map snd broken_blocks)
 155   let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 156   let formats = selectContinuationFormat (undefined {-TODO-}) live
 157   let block_infos = listToUFM $ map (\(info, block) -> (blockId block, info)) broken_blocks
 158   let blocks_with_live' = map (constructContinuation block_infos formats) blocks_with_live
 159   let blocks_with_live'' = map (destructContinuation block_infos formats) blocks_with_live'
 160   let blocks_with_live''' = map (transformReturn block_infos formats) blocks_with_live''
 161
 162   return $ [CmmProc info_table ident params blocks_with_live''']
 163
 164 --------------------------------------------------------------------------------
 165 -- Takes a basic block and returns a list of basic blocks that
 166 -- each have at most 1 CmmCall in them which must occur at the end.
 167 -- Also returns with each basic block, the variables that will
 168 -- be arguments to the continuation of the block once the call (if any) returns.
 169
 170 cmmBlockifyCalls :: [CmmBasicBlock] -> CPS [(CPSBlockInfo, CmmBasicBlock)]
 171 cmmBlockifyCalls blocks = liftM concat $ mapM breakBlock blocks
 172
 173 -- [(CmmReg,MachHint)] is the results from the previous block that are expected as parameters
 174 --breakBlock :: CmmBasicBlock -> CPS [(Maybe BlockId, CmmBasicBlock)]
 175 breakBlock :: CmmBasicBlock -> CPS [(CPSBlockInfo, CmmBasicBlock)]
 176 breakBlock (BasicBlock ident stmts) = breakBlock' ident ControlBlock [] stmts
 177
 178 breakBlock' current_id block_info accum_stmts [] =
 179   return [(block_info, BasicBlock current_id accum_stmts)]
 180 -- TODO: notice a call just before a branch, jump, call, etc.
 181 breakBlock' current_id block_info accum_stmts (stmt@(CmmCall _ results _ _):stmts) = do
 182   new_id <- newLabelCPS
 183   let new_block = (block_info, BasicBlock current_id (accum_stmts ++ [stmt, CmmBranch new_id]))
 184   rest <- breakBlock' new_id (ContinuationBlock results) [] stmts
 185   return $ (new_block:rest)
 186 breakBlock' current_id arguments accum_stmts (stmt:stmts) =
 187   breakBlock' current_id arguments (accum_stmts ++ [stmt]) stmts
 188
 189 --------------------------------------------------------------------------------
 190 cmmCPS :: DynFlags
 191        -> [Cmm]                 -- C-- with Proceedures
 192        -> IO [Cmm]              -- Output: CPS transformed C--
 193
 194 cmmCPS dflags abstractC = do
 195   when (dopt Opt_DoCmmLinting dflags) $
 196        do showPass dflags "CmmLint"
 197           case firstJust $ map cmmLint abstractC of
 198             Just err -> do printDump err
 199                            ghcExit dflags 1
 200             Nothing  -> return ()
 201   showPass dflags "CPS"
 202   -- TODO: check for use of branches to non-existant blocks
 203   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 204   -- continuationC <- return abstractC
 205   -- TODO: find out if it is valid to create a new unique source like this
 206   uniqSupply <- mkSplitUniqSupply 'p'
 207   let (_, continuationC) = runCPS (mapM (mapMCmmTop cpsProc) abstractC) (CPSState uniqSupply)
 208
 209   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 210   -- TODO: add option to dump Cmm to file
 211   return continuationC