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