compiler/cmm/CmmCPSGen.hs

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