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