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