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                  -- XXX: allow for interruptible suspension
 237                  , CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ]
 238                  CmmUnsafe
 239                  CmmMayReturn,
 240      CmmCall call results new_args CmmUnsafe CmmMayReturn,
 241      CmmCall (CmmCallee resumeThread CCallConv)
 242                  [ CmmHinted new_base AddrHint ]
 243                  [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
 244                  CmmUnsafe
 245                  CmmMayReturn,
 246      -- Assign the result to BaseReg: we
 247      -- might now have a different Capability!
 248      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 249     caller_load ++
 250     loadThreadState tso_unique ++
 251     [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
 252     where
 253       (_, arg_stmts, new_args) =
 254           loadArgsIntoTemps argument_uniques arguments
 255       (caller_save, caller_load) =
 256           callerSaveVolatileRegs (Just [{-only system regs-}])
 257       new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg))
 258       id = LocalReg id_unique bWord
 259       tso_unique : base_unique : id_unique : argument_uniques = uniques
 260
 261 -- -----------------------------------------------------------------------------
 262 -- Save/restore the thread state in the TSO
 263
 264 suspendThread, resumeThread :: CmmExpr
 265 suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
 266 resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
 267
 268 -- This stuff can't be done in suspendThread/resumeThread, because it
 269 -- refers to global registers which aren't available in the C world.
 270
 271 saveThreadState :: [CmmStmt]
 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 :: CmmStmt
 283 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 284
 285 loadThreadState :: Unique -> [CmmStmt]
 286 loadThreadState tso_unique =
 287   [
 288         -- tso = CurrentTSO;
 289         CmmAssign (CmmLocal tso) stgCurrentTSO,
 290         -- Sp = tso->sp;
 291         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 292                               bWord),
 293         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 294         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 295                                     rESERVED_STACK_WORDS)
 296   ] ++
 297   openNursery ++
 298   -- and load the current cost centre stack from the TSO when profiling:
 299   if opt_SccProfilingOn
 300   then [CmmStore curCCSAddr
 301         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
 302   else []
 303   where tso = LocalReg tso_unique bWord -- TODO FIXME NOW
 304
 305
 306 openNursery :: [CmmStmt]
 307 openNursery = [
 308         -- Hp = CurrentNursery->free - 1;
 309         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
 310
 311         -- HpLim = CurrentNursery->start +
 312         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 313         CmmAssign hpLim
 314             (cmmOffsetExpr
 315                 (CmmLoad nursery_bdescr_start bWord)
 316                 (cmmOffset
 317                   (CmmMachOp mo_wordMul [
 318                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 319                       [CmmLoad nursery_bdescr_blocks b32],
 320                     CmmLit (mkIntCLit bLOCK_SIZE)
 321                    ])
 322                   (-1)
 323                 )
 324             )
 325    ]
 326
 327
 328 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 329 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 330 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 331 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 332
 333 tso_SP, tso_STACK, tso_CCCS :: ByteOff
 334 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 335 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 336 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 337
 338 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 339 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 340 tsoFieldB :: ByteOff -> ByteOff
 341 tsoFieldB off
 342   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 343   | otherwise          = off + fixedHdrSize * wORD_SIZE
 344
 345 tsoProfFieldB :: ByteOff -> ByteOff
 346 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 347
 348 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 349 stgSp             = CmmReg sp
 350 stgHp             = CmmReg hp
 351 stgCurrentTSO     = CmmReg currentTSO
 352 stgCurrentNursery = CmmReg currentNursery
 353
 354 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
 355 sp                = CmmGlobal Sp
 356 spLim             = CmmGlobal SpLim
 357 hp                = CmmGlobal Hp
 358 hpLim             = CmmGlobal HpLim
 359 currentTSO        = CmmGlobal CurrentTSO
 360 currentNursery    = CmmGlobal CurrentNursery
 361
 362 -----------------------------------------------------------------------------
 363 -- Functions that generate CmmStmt sequences
 364 -- for packing/unpacking continuations
 365 -- and entering/exiting functions
 366
 367 tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
 368 tail_call spRel target arguments
 369   = store_arguments ++ adjust_sp_reg spRel ++ jump where
 370     store_arguments =
 371         [stack_put spRel expr offset
 372          | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
 373         [global_put expr global
 374          | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
 375     jump = [CmmJump target arguments]
 376
 377     argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
 378
 379 adjust_sp_reg :: Int -> [CmmStmt]
 380 adjust_sp_reg spRel =
 381     if spRel == 0
 382     then []
 383     else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 384
 385 assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
 386 assign_gc_stack_use stack_use arg_stack max_frame_size =
 387     if max_frame_size > arg_stack
 388     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 389     else [CmmAssign stack_use (CmmReg spLimReg)]
 390          -- Trick the optimizer into eliminating the branch for us
 391
 392 {-
 393 UNUSED 2008-12-29
 394
 395 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 396 gc_stack_check gc_block max_frame_size
 397   = check_stack_limit where
 398     check_stack_limit = [
 399      CmmCondBranch
 400      (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
 401                 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 402                      CmmReg spLimReg])
 403      gc_block]
 404 -}
 405
 406 pack_continuation :: ContinuationFormat -- ^ The current format
 407                   -> ContinuationFormat -- ^ The return point format
 408                   -> [CmmStmt]
 409 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
 410                   (ContinuationFormat _ cont_id cont_frame_size live_regs)
 411   = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
 412   where
 413     continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
 414                             live_regs
 415     needs_header_set =
 416         case (curr_id, cont_id) of
 417           (Just x, Just y) -> x /= y
 418           _ -> isJust cont_id
 419
 420     maybe_header = if needs_header_set
 421                    then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
 422                    else Nothing
 423
 424 pack_frame :: WordOff         -- ^ Current frame size
 425            -> WordOff         -- ^ Next frame size
 426            -> Maybe CmmExpr   -- ^ Next frame header if any
 427            -> [Maybe CmmExpr] -- ^ Next frame data
 428            -> [CmmStmt]
 429 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
 430     store_live_values ++ set_stack_header
 431     where
 432     -- TODO: only save variables when actually needed
 433     -- (may be handled by latter pass)
 434     store_live_values =
 435         [stack_put spRel expr offset
 436          | (expr, offset) <- cont_offsets]
 437     set_stack_header =
 438         case next_frame_header of
 439           Nothing -> []
 440           Just expr -> [stack_put spRel expr 0]
 441
 442     -- TODO: factor with function_entry and CmmInfo.hs(?)
 443     cont_offsets = mkOffsets label_size frame_args
 444
 445     label_size = 1 :: WordOff
 446
 447     mkOffsets _    [] = []
 448     mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
 449     mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
 450         where
 451           width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
 452           -- TODO: it would be better if we had a machRepWordWidth
 453
 454     spRel = curr_frame_size - next_frame_size
 455
 456
 457 -- Lazy adjustment of stack headers assumes all blocks
 458 -- that could branch to eachother (i.e. control blocks)
 459 -- have the same stack format (this causes a problem
 460 -- only for proc-point).
 461 function_entry :: ContinuationFormat -> [CmmStmt]
 462 function_entry (ContinuationFormat formals _ _ live_regs)
 463   = load_live_values ++ load_args where
 464     -- TODO: only save variables when actually needed
 465     -- (may be handled by latter pass)
 466     load_live_values =
 467         [stack_get 0 reg offset
 468          | (reg, offset) <- curr_offsets]
 469     load_args =
 470         [stack_get 0 reg offset
 471          | (reg, StackParam offset) <- argument_formats] ++
 472         [global_get reg global
 473          | (reg, RegisterParam global) <- argument_formats]
 474
 475     argument_formats = assignArguments (localRegType) formals
 476
 477     -- TODO: eliminate copy/paste with pack_continuation
 478     curr_offsets = mkOffsets label_size live_regs
 479
 480     label_size = 1 :: WordOff
 481
 482     mkOffsets _    [] = []
 483     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 484     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 485         where
 486           width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
 487           -- TODO: it would be better if we had a machRepWordWidth
 488
 489 -----------------------------------------------------------------------------
 490 -- Section: Stack and argument register puts and gets
 491 -----------------------------------------------------------------------------
 492 -- TODO: document
 493
 494 -- |Construct a 'CmmStmt' that will save a value on the stack
 495 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 496                                 -- is relative to (added to offset)
 497           -> CmmExpr            -- ^ What to store onto the stack
 498           -> WordOff            -- ^ Where on the stack to store it
 499                                 -- (positive <=> higher addresses)
 500           -> CmmStmt
 501 stack_put spRel expr offset =
 502     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 503
 504 --------------------------------
 505 -- |Construct a
 506 stack_get :: WordOff
 507           -> LocalReg
 508           -> WordOff
 509           -> CmmStmt
 510 stack_get spRel reg offset =
 511     CmmAssign (CmmLocal reg)
 512               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 513                        (localRegType reg))
 514 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 515 global_put expr global = CmmAssign (CmmGlobal global) expr
 516 global_get :: LocalReg -> GlobalReg -> CmmStmt
 517 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))