compiler/cmm/CmmCPSGen.hs

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