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