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