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