compiler/cmm/CmmCPSGen.hs

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