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