compiler/cmm/CmmCPSGen.hs

   1 module CmmCPSGen (
   2   -- | Converts continuations into full proceedures.
   3   -- The main work of the CPS transform that everything else is setting-up.
   4   continuationToProc,
   5   Continuation(..), continuationLabel,
   6   ContinuationFormat(..),
   7 ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Cmm
  12 import CLabel
  13 import CmmBrokenBlock -- Data types only
  14 import MachOp
  15 import CmmUtils
  16 import CmmCallConv
  17
  18 import CgProf
  19 import CgUtils
  20 import CgInfoTbls
  21 import SMRep
  22 import ForeignCall
  23
  24 import Constants
  25 import StaticFlags
  26 import Unique
  27 import Maybe
  28 import List
  29
  30 import Panic
  31
  32 -- The format for the call to a continuation
  33 -- The fst is the arguments that must be passed to the continuation
  34 -- by the continuation's caller.
  35 -- The snd is the live values that must be saved on stack.
  36 -- A Nothing indicates an ignored slot.
  37 -- The head of each list is the stack top or the first parameter.
  38
  39 -- The format for live values for a particular continuation
  40 -- All on stack for now.
  41 -- Head element is the top of the stack (or just under the header).
  42 -- Nothing means an empty slot.
  43 -- Future possibilities include callee save registers (i.e. passing slots in register)
  44 -- and heap memory (not sure if that's usefull at all though, but it may
  45 -- be worth exploring the design space).
  46
  47 continuationLabel (Continuation _ l _ _ _) = l
  48 data Continuation info =
  49   Continuation
  50      info              -- Left <=> Continuation created by the CPS
  51                        -- Right <=> Function or Proc point
  52      CLabel            -- Used to generate both info & entry labels
  53      CmmFormals        -- Argument locals live on entry (C-- procedure params)
  54      Bool              -- ^ True <=> GC block so ignore stack size
  55      [BrokenBlock]     -- Code, may be empty.  The first block is
  56                        -- the entry point.  The order is otherwise initially
  57                        -- unimportant, but at some point the code gen will
  58                        -- fix the order.
  59
  60                        -- the BlockId of the first block does not give rise
  61                        -- to a label.  To jump to the first block in a Proc,
  62                        -- use the appropriate CLabel.
  63
  64 data ContinuationFormat
  65     = ContinuationFormat {
  66         continuation_formals :: CmmFormals,
  67         continuation_label :: Maybe CLabel,     -- The label occupying the top slot
  68         continuation_frame_size :: WordOff,     -- Total frame size in words (not including arguments)
  69         continuation_stack :: [Maybe LocalReg]  -- local reg offsets from stack top
  70       }
  71
  72 -- A block can be a continuation of a call
  73 -- A block can be a continuation of another block (w/ or w/o joins)
  74 -- A block can be an entry to a function
  75
  76 -----------------------------------------------------------------------------
  77 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
  78                    -> CmmReg
  79                    -> [[[Unique]]]
  80                    -> Continuation CmmInfo
  81                    -> CmmTop
  82 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
  83                    (Continuation info label formals _ blocks) =
  84     CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
  85     where
  86       curr_format = maybe unknown_block id $ lookup label formats
  87       unknown_block = panic "unknown BlockId in continuationToProc"
  88       curr_stack = continuation_frame_size curr_format
  89       arg_stack = argumentsSize localRegRep formals
  90
  91       param_stmts :: [CmmStmt]
  92       param_stmts = function_entry curr_format
  93
  94       gc_stmts :: [CmmStmt]
  95       gc_stmts =
  96         assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
  97
  98       update_stmts :: [CmmStmt]
  99       update_stmts =
 100           case info of
 101             CmmInfo _ (Just (UpdateFrame target args)) _ ->
 102                 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
 103                 adjust_sp_reg (curr_stack - update_frame_size)
 104             CmmInfo _ Nothing _ -> []
 105
 106       continuationToProc' :: [[Unique]]
 107                           -> BrokenBlock
 108                           -> Bool
 109                           -> [CmmBasicBlock]
 110       continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
 111           prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
 112           where
 113             prefix_blocks =
 114                 if is_entry
 115                 then [BasicBlock
 116                       (BlockId prefix_unique)
 117                       (param_stmts ++ [CmmBranch ident])]
 118                 else []
 119
 120             (prefix_unique : call_uniques) : new_block_uniques = uniques
 121             toCLabel = mkReturnPtLabel . getUnique
 122
 123             block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
 124             block_for_branch unique next
 125                 -- branches to the current function don't have to jump
 126                 | (mkReturnPtLabel $ getUnique next) == label
 127                 = (next, [])
 128
 129                 -- branches to any other function have to jump
 130                 | (Just cont_format) <- lookup (toCLabel next) formats
 131                 = let
 132                     new_next = BlockId unique
 133                     cont_stack = continuation_frame_size cont_format
 134                     arguments = map formal_to_actual (continuation_formals cont_format)
 135                   in (new_next,
 136                      [BasicBlock new_next $
 137                       pack_continuation curr_format cont_format ++
 138                       tail_call (curr_stack - cont_stack)
 139                               (CmmLit $ CmmLabel $ toCLabel next)
 140                               arguments])
 141
 142                 -- branches to blocks in the current function don't have to jump
 143                 | otherwise
 144                 = (next, [])
 145
 146             -- Wrapper for block_for_branch for when the target
 147             -- is inside a 'Maybe'.
 148             block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
 149             block_for_branch' _ Nothing = (Nothing, [])
 150             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
 151               where (new_next, new_blocks) = block_for_branch unique next
 152
 153             -- If the target of a switch, branch or cond branch becomes a proc point
 154             -- then we have to make a new block what will then *jump* to the original target.
 155             proc_point_fix unique (CmmCondBranch test target)
 156                 = (CmmCondBranch test new_target, new_blocks)
 157                   where (new_target, new_blocks) = block_for_branch (head unique) target
 158             proc_point_fix unique (CmmSwitch test targets)
 159                 = (CmmSwitch test new_targets, concat new_blocks)
 160                   where (new_targets, new_blocks) =
 161                             unzip $ zipWith block_for_branch' unique targets
 162             proc_point_fix unique (CmmBranch target)
 163                 = (CmmBranch new_target, new_blocks)
 164                   where (new_target, new_blocks) = block_for_branch (head unique) target
 165             proc_point_fix _ other = (other, [])
 166
 167             (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
 168             main_stmts =
 169                 case entry of
 170                   FunctionEntry _ _ _ ->
 171                       -- Ugh, the statements for an update frame must come
 172                       -- *after* the GC check that was added at the beginning
 173                       -- of the CPS pass.  So we have do edit the statements
 174                       -- a bit.  This depends on the knowledge that the
 175                       -- statements in the first block are only the GC check.
 176                       -- That's fragile but it works for now.
 177                       gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
 178                   ControlEntry -> stmts ++ postfix_stmts
 179                   ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
 180             postfix_stmts = case exit of
 181                         -- Branches and switches may get modified by proc_point_fix
 182                         FinalBranch next -> [CmmBranch next]
 183                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 184
 185                         -- A return is a tail call to the stack top
 186                         FinalReturn arguments ->
 187                             tail_call curr_stack
 188                                 (entryCode (CmmLoad (CmmReg spReg) wordRep))
 189                                 arguments
 190
 191                         -- A tail call
 192                         FinalJump target arguments ->
 193                             tail_call curr_stack target arguments
 194
 195                         -- A regular Cmm function call
 196                         FinalCall next (CmmCallee target CmmCallConv)
 197                             results arguments _ _ _ ->
 198                                 pack_continuation curr_format cont_format ++
 199                                 tail_call (curr_stack - cont_stack)
 200                                               target arguments
 201                             where
 202                               cont_format = maybe unknown_block id $
 203                                             lookup (mkReturnPtLabel $ getUnique next) formats
 204                               cont_stack = continuation_frame_size cont_format
 205
 206                         -- A safe foreign call
 207                         FinalCall next (CmmCallee target conv)
 208                             results arguments _ _ _ ->
 209                                 target_stmts ++
 210                                 foreignCall call_uniques' (CmmCallee new_target conv)
 211                                             results arguments
 212                             where
 213                               (call_uniques', target_stmts, new_target) =
 214                                   maybeAssignTemp call_uniques target
 215
 216                         -- A safe prim call
 217                         FinalCall next (CmmPrim target)
 218                             results arguments _ _ _ ->
 219                                 foreignCall call_uniques (CmmPrim target)
 220                                             results arguments
 221
 222 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 223
 224 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
 225 foreignCall uniques call results arguments =
 226     arg_stmts ++
 227     saveThreadState ++
 228     caller_save ++
 229     [CmmCall (CmmCallee suspendThread CCallConv)
 230                  [ (id,PtrHint) ]
 231                  [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 232                  CmmUnsafe
 233                  CmmMayReturn,
 234      CmmCall call results new_args CmmUnsafe CmmMayReturn,
 235      CmmCall (CmmCallee resumeThread CCallConv)
 236                  [ (new_base, PtrHint) ]
 237                  [ (CmmReg (CmmLocal id), PtrHint) ]
 238                  CmmUnsafe
 239                  CmmMayReturn,
 240      -- Assign the result to BaseReg: we
 241      -- might now have a different Capability!
 242      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 243     caller_load ++
 244     loadThreadState tso_unique ++
 245     [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
 246     where
 247       (_, arg_stmts, new_args) =
 248           loadArgsIntoTemps argument_uniques arguments
 249       (caller_save, caller_load) =
 250           callerSaveVolatileRegs (Just [{-only system regs-}])
 251       new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
 252       id = LocalReg id_unique wordRep KindNonPtr
 253       tso_unique : base_unique : id_unique : argument_uniques = uniques
 254
 255 -- -----------------------------------------------------------------------------
 256 -- Save/restore the thread state in the TSO
 257
 258 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 259 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 260
 261 -- This stuff can't be done in suspendThread/resumeThread, because it
 262 -- refers to global registers which aren't available in the C world.
 263
 264 saveThreadState =
 265   -- CurrentTSO->sp = Sp;
 266   [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
 267   closeNursery] ++
 268   -- and save the current cost centre stack in the TSO when profiling:
 269   if opt_SccProfilingOn
 270   then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
 271   else []
 272
 273    -- CurrentNursery->free = Hp+1;
 274 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 275
 276 loadThreadState tso_unique =
 277   [
 278         -- tso = CurrentTSO;
 279         CmmAssign (CmmLocal tso) stgCurrentTSO,
 280         -- Sp = tso->sp;
 281         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 282                               wordRep),
 283         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 284         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 285                                     rESERVED_STACK_WORDS)
 286   ] ++
 287   openNursery ++
 288   -- and load the current cost centre stack from the TSO when profiling:
 289   if opt_SccProfilingOn
 290   then [CmmStore curCCSAddr
 291         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
 292   else []
 293   where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
 294
 295
 296 openNursery = [
 297         -- Hp = CurrentNursery->free - 1;
 298         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 299
 300         -- HpLim = CurrentNursery->start +
 301         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 302         CmmAssign hpLim
 303             (cmmOffsetExpr
 304                 (CmmLoad nursery_bdescr_start wordRep)
 305                 (cmmOffset
 306                   (CmmMachOp mo_wordMul [
 307                     CmmMachOp (MO_S_Conv I32 wordRep)
 308                       [CmmLoad nursery_bdescr_blocks I32],
 309                     CmmLit (mkIntCLit bLOCK_SIZE)
 310                    ])
 311                   (-1)
 312                 )
 313             )
 314    ]
 315
 316
 317 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 318 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 319 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 320
 321 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 322 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 323 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 324
 325 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 326 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 327 tsoFieldB :: ByteOff -> ByteOff
 328 tsoFieldB off
 329   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 330   | otherwise          = off + fixedHdrSize * wORD_SIZE
 331
 332 tsoProfFieldB :: ByteOff -> ByteOff
 333 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 334
 335 stgSp             = CmmReg sp
 336 stgHp             = CmmReg hp
 337 stgCurrentTSO     = CmmReg currentTSO
 338 stgCurrentNursery = CmmReg currentNursery
 339
 340 sp                = CmmGlobal Sp
 341 spLim             = CmmGlobal SpLim
 342 hp                = CmmGlobal Hp
 343 hpLim             = CmmGlobal HpLim
 344 currentTSO        = CmmGlobal CurrentTSO
 345 currentNursery    = CmmGlobal CurrentNursery
 346
 347 -----------------------------------------------------------------------------
 348 -- Functions that generate CmmStmt sequences
 349 -- for packing/unpacking continuations
 350 -- and entering/exiting functions
 351
 352 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 353 tail_call spRel target arguments
 354   = store_arguments ++ adjust_sp_reg spRel ++ jump where
 355     store_arguments =
 356         [stack_put spRel expr offset
 357          | ((expr, _), StackParam offset) <- argument_formats] ++
 358         [global_put expr global
 359          | ((expr, _), RegisterParam global) <- argument_formats]
 360     jump = [CmmJump target arguments]
 361
 362     argument_formats = assignArguments (cmmExprRep . fst) arguments
 363
 364 adjust_sp_reg spRel =
 365     if spRel == 0
 366     then []
 367     else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 368
 369 assign_gc_stack_use stack_use arg_stack max_frame_size =
 370     if max_frame_size > arg_stack
 371     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 372     else [CmmAssign stack_use (CmmReg spLimReg)]
 373          -- Trick the optimizer into eliminating the branch for us
 374
 375 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 376 gc_stack_check gc_block max_frame_size
 377   = check_stack_limit where
 378     check_stack_limit = [
 379      CmmCondBranch
 380      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 381                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 382                      CmmReg spLimReg])
 383      gc_block]
 384
 385
 386 pack_continuation :: ContinuationFormat -- ^ The current format
 387                   -> ContinuationFormat -- ^ The return point format
 388                   -> [CmmStmt]
 389 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
 390                   (ContinuationFormat _ cont_id cont_frame_size live_regs)
 391   = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
 392   where
 393     continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
 394                             live_regs
 395     needs_header_set =
 396         case (curr_id, cont_id) of
 397           (Just x, Just y) -> x /= y
 398           _ -> isJust cont_id
 399
 400     maybe_header = if needs_header_set
 401                    then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
 402                    else Nothing
 403
 404 pack_frame :: WordOff         -- ^ Current frame size
 405            -> WordOff         -- ^ Next frame size
 406            -> Maybe CmmExpr   -- ^ Next frame header if any
 407            -> [Maybe CmmExpr] -- ^ Next frame data
 408            -> [CmmStmt]
 409 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
 410     store_live_values ++ set_stack_header
 411     where
 412     -- TODO: only save variables when actually needed
 413     -- (may be handled by latter pass)
 414     store_live_values =
 415         [stack_put spRel expr offset
 416          | (expr, offset) <- cont_offsets]
 417     set_stack_header =
 418         case next_frame_header of
 419           Nothing -> []
 420           Just expr -> [stack_put spRel expr 0]
 421
 422     -- TODO: factor with function_entry and CmmInfo.hs(?)
 423     cont_offsets = mkOffsets label_size frame_args
 424
 425     label_size = 1 :: WordOff
 426
 427     mkOffsets size [] = []
 428     mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
 429     mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
 430         where
 431           width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
 432           -- TODO: it would be better if we had a machRepWordWidth
 433
 434     spRel = curr_frame_size - next_frame_size
 435
 436
 437 -- Lazy adjustment of stack headers assumes all blocks
 438 -- that could branch to eachother (i.e. control blocks)
 439 -- have the same stack format (this causes a problem
 440 -- only for proc-point).
 441 function_entry :: ContinuationFormat -> [CmmStmt]
 442 function_entry (ContinuationFormat formals _ _ live_regs)
 443   = load_live_values ++ load_args where
 444     -- TODO: only save variables when actually needed
 445     -- (may be handled by latter pass)
 446     load_live_values =
 447         [stack_get 0 reg offset
 448          | (reg, offset) <- curr_offsets]
 449     load_args =
 450         [stack_get 0 reg offset
 451          | (reg, StackParam offset) <- argument_formats] ++
 452         [global_get reg global
 453          | (reg, RegisterParam global) <- argument_formats]
 454
 455     argument_formats = assignArguments (localRegRep) formals
 456
 457     -- TODO: eliminate copy/paste with pack_continuation
 458     curr_offsets = mkOffsets label_size live_regs
 459
 460     label_size = 1 :: WordOff
 461
 462     mkOffsets size [] = []
 463     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 464     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 465         where
 466           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 467           -- TODO: it would be better if we had a machRepWordWidth
 468
 469 -----------------------------------------------------------------------------
 470 -- Section: Stack and argument register puts and gets
 471 -----------------------------------------------------------------------------
 472 -- TODO: document
 473
 474 -- |Construct a 'CmmStmt' that will save a value on the stack
 475 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 476                                 -- is relative to (added to offset)
 477           -> CmmExpr            -- ^ What to store onto the stack
 478           -> WordOff            -- ^ Where on the stack to store it
 479                                 -- (positive <=> higher addresses)
 480           -> CmmStmt
 481 stack_put spRel expr offset =
 482     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 483
 484 --------------------------------
 485 -- |Construct a
 486 stack_get :: WordOff
 487           -> LocalReg
 488           -> WordOff
 489           -> CmmStmt
 490 stack_get spRel reg offset =
 491     CmmAssign (CmmLocal reg)
 492               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 493                        (localRegRep reg))
 494 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 495 global_put expr global = CmmAssign (CmmGlobal global) expr
 496 global_get :: LocalReg -> GlobalReg -> CmmStmt
 497 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))