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 (fixedpoint)
  10 import CmmLive
  11 import CmmCPSData
  12 import CmmProcPoint
  13
  14 import MachOp
  15 import ForeignCall
  16 import CLabel
  17 import SMRep
  18 import Constants
  19
  20 import DynFlags
  21 import ErrUtils
  22 import Maybes
  23 import Outputable
  24 import UniqSupply
  25 import UniqFM
  26 import UniqSet
  27 import Unique
  28
  29 import Monad
  30 import IO
  31 import Data.List
  32
  33 --------------------------------------------------------------------------------
  34
  35 -- The format for the call to a continuation
  36 -- The fst is the arguments that must be passed to the continuation
  37 -- by the continuation's caller.
  38 -- The snd is the live values that must be saved on stack.
  39 -- A Nothing indicates an ignored slot.
  40 -- The head of each list is the stack top or the first parameter.
  41
  42 -- The format for live values for a particular continuation
  43 -- All on stack for now.
  44 -- Head element is the top of the stack (or just under the header).
  45 -- Nothing means an empty slot.
  46 -- Future possibilities include callee save registers (i.e. passing slots in register)
  47 -- and heap memory (not sure if that's usefull at all though, but it may
  48 -- be worth exploring the design space).
  49
  50 continuationLabel (Continuation _ _ l _ _) = l
  51 data Continuation =
  52   Continuation
  53      Bool              -- True => Function entry, False => Continuation/return point
  54      [CmmStatic]       -- Info table, may be empty
  55      CLabel            -- Used to generate both info & entry labels
  56      CmmFormals        -- Argument locals live on entry (C-- procedure params)
  57      [BrokenBlock]   -- Code, may be empty.  The first block is
  58                        -- the entry point.  The order is otherwise initially
  59                        -- unimportant, but at some point the code gen will
  60                        -- fix the order.
  61
  62                        -- the BlockId of the first block does not give rise
  63                        -- to a label.  To jump to the first block in a Proc,
  64                        -- use the appropriate CLabel.
  65
  66 -- Describes the layout of a stack frame for a continuation
  67 data StackFormat
  68     = StackFormat
  69          (Maybe CLabel)         -- The label occupying the top slot
  70          WordOff                -- Total frame size in words
  71          [(CmmReg, WordOff)]    -- local reg offsets from stack top
  72
  73 -- A block can be a continuation of a call
  74 -- A block can be a continuation of another block (w/ or w/o joins)
  75 -- A block can be an entry to a function
  76
  77 -----------------------------------------------------------------------------
  78
  79 collectNonProcPointTargets ::
  80     UniqSet BlockId -> BlockEnv BrokenBlock
  81     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
  82 collectNonProcPointTargets proc_points blocks current_targets block =
  83     if sizeUniqSet current_targets == sizeUniqSet new_targets
  84        then current_targets
  85        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
  86     where
  87       block' = lookupWithDefaultUFM blocks (panic "TODO") block
  88       targets =
  89         -- Note the subtlety that since the extra branch after a call
  90         -- will always be to a block that is a proc-point,
  91         -- this subtraction will always remove that case
  92         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
  93         -- TODO: remove redundant uniqSetToList
  94       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
  95
  96 procPointToContinuation ::
  97     UniqSet BlockId -> BlockEnv BrokenBlock
  98     -> BlockId -> Continuation
  99 procPointToContinuation proc_points blocks start =
 100   Continuation is_entry info_table clabel params body
 101     where
 102       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 103       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 104       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 105       body = start_block : children_blocks
 106       info_table = [] -- TODO
 107       start_block_entry = brokenBlockEntry start_block
 108       is_entry = case start_block_entry of
 109                    FunctionEntry _ _ -> True
 110                    _ -> False
 111       clabel = case start_block_entry of
 112                  FunctionEntry label _ -> label
 113                  _ -> mkReturnPtLabel $ getUnique start
 114       params = case start_block_entry of
 115                  FunctionEntry _ args -> args
 116                  ContinuationEntry args -> args
 117                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 118
 119 --------------------------------------------------------------------------------
 120 -- For now just select the continuation orders in the order they are in the set with no gaps
 121
 122 selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 123 selectStackFormat live continuations =
 124     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 125     where
 126       selectStackFormat' (Continuation True info_table label formals blocks) =
 127           --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 128           --in
 129           StackFormat (Just label) 0 []
 130       selectStackFormat' (Continuation False info_table label formals blocks) =
 131           -- TODO: assumes the first block is the entry block
 132           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 133           in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
 134
 135       live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
 136       live_to_format label formals live =
 137           foldl extend_format
 138                     (StackFormat (Just label) retAddrSizeW [])
 139                     (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
 140
 141       extend_format :: StackFormat -> LocalReg -> StackFormat
 142       extend_format (StackFormat label size offsets) reg =
 143           StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 144
 145       slot_size :: LocalReg -> Int
 146       slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 147
 148       unknown_block = panic "unknown BlockId in selectStackFormat"
 149
 150 continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 151 continuationToProc formats (Continuation is_entry info label formals blocks) =
 152     CmmProc info label formals (map (continuationToProc' label formats) blocks)
 153     where
 154       continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 155                              -> CmmBasicBlock
 156       continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 157           BasicBlock ident (prefix++stmts++postfix)
 158           where
 159             curr_format = maybe unknown_block id $ lookup curr_ident formats
 160             unknown_block = panic "unknown BlockId in continuationToProc"
 161             prefix = case entry of
 162                        ControlEntry -> []
 163                        FunctionEntry _ _ -> []
 164                        ContinuationEntry formals ->
 165                            unpack_continuation curr_format
 166             postfix = case exit of
 167                         FinalBranch next -> [CmmBranch next]
 168                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 169                         FinalReturn arguments ->
 170                             exit_function curr_format
 171                                 (CmmLoad (CmmReg spReg) wordRep)
 172                                 arguments
 173                         FinalJump target arguments ->
 174                             exit_function curr_format target arguments
 175                         -- TODO: do something about global saves
 176                         FinalCall next (CmmForeignCall target CmmCallConv)
 177                             results arguments saves ->
 178                                 pack_continuation curr_format cont_format ++
 179                                 [CmmJump target arguments]
 180                             where
 181                               cont_format = maybe unknown_block id $
 182                                             lookup (mkReturnPtLabel $ getUnique next) formats
 183                         FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 184
 185 --------------------------------------------------------------------------------
 186 -- Functions that generate CmmStmt sequences
 187 -- for packing/unpacking continuations
 188 -- and entering/exiting functions
 189
 190 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 191 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 192   = adjust_spReg ++ jump where
 193     adjust_spReg =
 194         if curr_frame_size == 0
 195         then []
 196         else [CmmAssign spReg
 197                  (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 198     jump = [CmmJump target arguments]
 199
 200 enter_function :: WordOff -> [CmmStmt]
 201 enter_function max_frame_size
 202   = check_stack_limit where
 203     check_stack_limit = [
 204      CmmCondBranch
 205      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 206                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 207      gc_block]
 208     gc_block = undefined -- TODO: get stack and heap checks to go to same
 209
 210 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 211 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 212 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 213                        (StackFormat cont_id cont_frame_size cont_offsets)
 214   = save_live_values ++ set_stack_header ++ adjust_spReg where
 215     -- TODO: only save variables when actually needed
 216     save_live_values =
 217         [CmmStore
 218          (CmmRegOff
 219           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 220          (CmmReg reg)
 221          | (reg, offset) <- cont_offsets]
 222     needs_header =
 223       case (curr_id, cont_id) of
 224         (Just x, Just y) -> x /= y
 225         _ -> isJust cont_id
 226     set_stack_header =
 227       if not needs_header
 228          then []
 229          else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 230     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 231     adjust_spReg =
 232         if curr_frame_size == cont_frame_size
 233         then []
 234         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 235
 236 -- Lazy adjustment of stack headers assumes all blocks
 237 -- that could branch to eachother (i.e. control blocks)
 238 -- have the same stack format (this causes a problem
 239 -- only for proc-point).
 240 unpack_continuation :: StackFormat -> [CmmStmt]
 241 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 242   = load_live_values where
 243     -- TODO: only save variables when actually needed
 244     load_live_values =
 245         [CmmAssign
 246          reg
 247          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 248          | (reg, offset) <- curr_offsets]
 249
 250 -----------------------------------------------------------------------------
 251 -- Breaking basic blocks on function calls
 252 -----------------------------------------------------------------------------
 253
 254 -----------------------------------------------------------------------------
 255 -- Takes a basic block and breaks it up into a list of broken blocks
 256 --
 257 -- Takes a basic block and returns a list of basic blocks that
 258 -- each have at most 1 CmmCall in them which must occur at the end.
 259 -- Also returns with each basic block, the variables that will
 260 -- be arguments to the continuation of the block once the call (if any)
 261 -- returns.
 262
 263 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
 264 breakBlock uniques (BasicBlock ident stmts) entry =
 265     breakBlock' uniques ident entry [] [] stmts where
 266         breakBlock' uniques current_id entry exits accum_stmts stmts =
 267             case stmts of
 268               [] -> panic "block doesn't end in jump, goto or return"
 269               [CmmJump target arguments] ->
 270                   [BrokenBlock current_id entry accum_stmts
 271                                exits
 272                                (FinalJump target arguments)]
 273               [CmmReturn arguments] ->
 274                   [BrokenBlock current_id entry accum_stmts
 275                                exits
 276                                (FinalReturn arguments)]
 277               [CmmBranch target] ->
 278                   [BrokenBlock current_id entry accum_stmts
 279                                (target:exits)
 280                                (FinalBranch target)]
 281               [CmmSwitch expr targets] ->
 282                   [BrokenBlock current_id entry accum_stmts
 283                                (mapMaybe id targets ++ exits)
 284                                (FinalSwitch expr targets)]
 285               (CmmJump _ _:_) ->
 286                   panic "jump in middle of block"
 287               (CmmReturn _:_) ->
 288                   panic "return in middle of block"
 289               (CmmBranch _:_) ->
 290                   panic "branch in middle of block"
 291               (CmmSwitch _ _:_) ->
 292                   panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
 293               (CmmCall target results arguments saves:stmts) -> block : rest
 294                   where
 295                     new_id = BlockId $ head uniques
 296                     block = BrokenBlock current_id entry accum_stmts
 297                             (new_id:exits)
 298                             (FinalCall new_id target results arguments saves)
 299                     rest = breakBlock' (tail uniques) new_id
 300                            (ContinuationEntry results) [] [] stmts
 301               (s@(CmmCondBranch test target):stmts) ->
 302                   breakBlock' uniques current_id entry
 303                               (target:exits) (accum_stmts++[s]) stmts
 304               (s:stmts) ->
 305                   breakBlock' uniques current_id entry
 306                               exits (accum_stmts++[s]) stmts
 307
 308 --------------------------------
 309 -- Convert from a BrokenBlock
 310 -- to a CmmBasicBlock so the
 311 -- liveness analysis can run
 312 -- on it.
 313 --------------------------------
 314 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 315 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 316     BasicBlock ident (stmts++exit_stmt)
 317     where
 318       exit_stmt =
 319           case exit of
 320             FinalBranch target -> [CmmBranch target]
 321             FinalReturn arguments -> [CmmReturn arguments]
 322             FinalJump target arguments -> [CmmJump target arguments]
 323             FinalSwitch expr targets -> [CmmSwitch expr targets]
 324             FinalCall branch_target call_target results arguments saves ->
 325                 [CmmCall call_target results arguments saves,
 326                  CmmBranch branch_target]
 327
 328 -----------------------------------------------------------------------------
 329 -- CPS a single CmmTop (proceedure)
 330 -----------------------------------------------------------------------------
 331
 332 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 333 cpsProc uniqSupply x@(CmmData _ _) = [x]
 334 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
 335     where
 336       uniqes :: [[Unique]]
 337       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 338
 339       -- Break the block at each function call
 340       broken_blocks :: [BrokenBlock]
 341       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
 342                                         (FunctionEntry ident params:repeat ControlEntry)
 343
 344       -- Calculate live variables for each broken block
 345       live :: BlockEntryLiveness
 346       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 347              -- nothing can be live on entry to the first block so we could take the tail
 348
 349       proc_points :: UniqSet BlockId
 350       proc_points = calculateProcPoints broken_blocks
 351
 352       -- TODO: insert proc point code here
 353       --  * Branches and switches to proc points may cause new blocks to be created
 354       --    (or proc points could leave behind phantom blocks that just jump to them)
 355       --  * Proc points might get some live variables passed as arguments
 356
 357       continuations :: [Continuation]
 358       continuations = map (procPointToContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
 359
 360       -- Select the stack format on entry to each block
 361       formats :: [(CLabel, StackFormat)]
 362       formats = selectStackFormat live continuations
 363
 364       -- Do the actual CPS transform
 365       cps_procs :: [CmmTop]
 366       cps_procs = map (continuationToProc formats) continuations
 367
 368 --------------------------------------------------------------------------------
 369 cmmCPS :: DynFlags
 370        -> [Cmm]                 -- C-- with Proceedures
 371        -> IO [Cmm]              -- Output: CPS transformed C--
 372
 373 cmmCPS dflags abstractC = do
 374   when (dopt Opt_DoCmmLinting dflags) $
 375        do showPass dflags "CmmLint"
 376           case firstJust $ map cmmLint abstractC of
 377             Just err -> do printDump err
 378                            ghcExit dflags 1
 379             Nothing  -> return ()
 380   showPass dflags "CPS"
 381   -- TODO: check for use of branches to non-existant blocks
 382   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 383   -- TODO: find out if it is valid to create a new unique source like this
 384   uniqSupply <- mkSplitUniqSupply 'p'
 385   let supplies = listSplitUniqSupply uniqSupply
 386   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 387
 388   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 389   -- TODO: add option to dump Cmm to file
 390   return continuationC