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