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         assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
 101
 102       update_stmts :: [CmmStmt]
 103       update_stmts =
 104           case info of
 105             CmmInfo _ (Just (UpdateFrame target args)) _ ->
 106                 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
 107                 adjust_sp_reg (curr_stack - update_frame_size)
 108             CmmInfo _ Nothing _ -> []
 109
 110 -- At present neither the Cmm parser nor the code generator
 111 -- produce code that will allow the target of a CmmCondBranch
 112 -- or a CmmSwitch to become a continuation or a proc-point.
 113 -- If future revisions, might allow these to happen
 114 -- then special care will have to be take to allow for that case.
 115       continuationToProc' :: [Unique]
 116                           -> BrokenBlock
 117                           -> Bool
 118                           -> [CmmBasicBlock]
 119       continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
 120           prefix_blocks ++ [main_block]
 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 = uniques
 130             toCLabel = mkReturnPtLabel . getUnique
 131
 132             block_for_branch unique next
 133                 | (Just cont_format) <- lookup (toCLabel next) formats
 134                 = let
 135                     new_next = BlockId unique
 136                     cont_stack = continuation_frame_size cont_format
 137                     arguments = map formal_to_actual (continuation_formals cont_format)
 138                   in (new_next,
 139                      [BasicBlock new_next $
 140                       pack_continuation False curr_format cont_format ++
 141                       tail_call (curr_stack - cont_stack)
 142                               (CmmLit $ CmmLabel $ toCLabel next)
 143                               arguments])
 144                 | otherwise
 145                 = (next, [])
 146
 147             block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
 148             block_for_branch' _ Nothing = (Nothing, [])
 149             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
 150               where (new_next, new_blocks) = block_for_branch unique next
 151
 152             main_block =
 153                 case entry of
 154                   FunctionEntry _ _ _ ->
 155                       -- Ugh, the statements for an update frame must come
 156                       -- *after* the GC check that was added at the beginning
 157                       -- of the CPS pass.  So we have do edit the statements
 158                       -- a bit.  This depends on the knowledge that the
 159                       -- statements in the first block are only the GC check.
 160                       -- That's fragile but it works for now.
 161                       BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
 162                   ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
 163                   ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
 164             postfix_stmts = case exit of
 165                         FinalBranch next ->
 166                             if (mkReturnPtLabel $ getUnique next) == label
 167                             then [CmmBranch next]
 168                             else case lookup (mkReturnPtLabel $ getUnique next) formats of
 169                               Nothing -> [CmmBranch next]
 170                               Just cont_format ->
 171                                 pack_continuation True curr_format cont_format ++
 172                                 tail_call (curr_stack - cont_stack)
 173                                           (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
 174                                           arguments
 175                                 where
 176                                   cont_stack = continuation_frame_size cont_format
 177                                   arguments = map formal_to_actual (continuation_formals cont_format)
 178                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 179                         FinalReturn arguments ->
 180                             tail_call curr_stack
 181                                 (CmmLoad (CmmReg spReg) wordRep)
 182                                 arguments
 183                         FinalJump target arguments ->
 184                             tail_call curr_stack target arguments
 185
 186                         -- A regular Cmm function call
 187                         FinalCall next (CmmForeignCall target CmmCallConv)
 188                             results arguments _ _ ->
 189                                 pack_continuation True curr_format cont_format ++
 190                                 tail_call (curr_stack - cont_stack)
 191                                               target arguments
 192                             where
 193                               cont_format = maybe unknown_block id $
 194                                             lookup (mkReturnPtLabel $ getUnique next) formats
 195                               cont_stack = continuation_frame_size cont_format
 196
 197                         -- A safe foreign call
 198                         FinalCall next (CmmForeignCall target conv)
 199                             results arguments _ _ ->
 200                                 target_stmts ++
 201                                 foreignCall call_uniques' (CmmForeignCall new_target conv)
 202                                             results arguments
 203                             where
 204                               (call_uniques', target_stmts, new_target) =
 205                                   maybeAssignTemp call_uniques target
 206
 207                         -- A safe prim call
 208                         FinalCall next (CmmPrim target)
 209                             results arguments _ _ ->
 210                                 foreignCall call_uniques (CmmPrim target)
 211                                             results arguments
 212
 213 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 214
 215 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
 216 foreignCall uniques call results arguments =
 217     arg_stmts ++
 218     saveThreadState ++
 219     caller_save ++
 220     [CmmCall (CmmForeignCall suspendThread CCallConv)
 221                  [ (id,PtrHint) ]
 222                  [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 223                  CmmUnsafe,
 224      CmmCall call results new_args CmmUnsafe,
 225      CmmCall (CmmForeignCall resumeThread CCallConv)
 226                  [ (new_base, PtrHint) ]
 227                  [ (CmmReg (CmmLocal id), PtrHint) ]
 228                  CmmUnsafe,
 229      -- Assign the result to BaseReg: we
 230      -- might now have a different Capability!
 231      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 232     caller_load ++
 233     loadThreadState tso_unique ++
 234     [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
 235     where
 236       (_, arg_stmts, new_args) =
 237           loadArgsIntoTemps argument_uniques arguments
 238       (caller_save, caller_load) =
 239           callerSaveVolatileRegs (Just [{-only system regs-}])
 240       new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
 241       id = LocalReg id_unique wordRep KindNonPtr
 242       tso_unique : base_unique : id_unique : argument_uniques = uniques
 243
 244 -- -----------------------------------------------------------------------------
 245 -- Save/restore the thread state in the TSO
 246
 247 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 248 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 249
 250 -- This stuff can't be done in suspendThread/resumeThread, because it
 251 -- refers to global registers which aren't available in the C world.
 252
 253 saveThreadState =
 254   -- CurrentTSO->sp = Sp;
 255   [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
 256   closeNursery] ++
 257   -- and save the current cost centre stack in the TSO when profiling:
 258   if opt_SccProfilingOn
 259   then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
 260   else []
 261
 262    -- CurrentNursery->free = Hp+1;
 263 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 264
 265 loadThreadState tso_unique =
 266   [
 267         -- tso = CurrentTSO;
 268         CmmAssign (CmmLocal tso) stgCurrentTSO,
 269         -- Sp = tso->sp;
 270         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 271                               wordRep),
 272         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 273         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 274                                     rESERVED_STACK_WORDS)
 275   ] ++
 276   openNursery ++
 277   -- and load the current cost centre stack from the TSO when profiling:
 278   if opt_SccProfilingOn
 279   then [CmmStore curCCSAddr
 280         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
 281   else []
 282   where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
 283
 284
 285 openNursery = [
 286         -- Hp = CurrentNursery->free - 1;
 287         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 288
 289         -- HpLim = CurrentNursery->start +
 290         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 291         CmmAssign hpLim
 292             (cmmOffsetExpr
 293                 (CmmLoad nursery_bdescr_start wordRep)
 294                 (cmmOffset
 295                   (CmmMachOp mo_wordMul [
 296                     CmmMachOp (MO_S_Conv I32 wordRep)
 297                       [CmmLoad nursery_bdescr_blocks I32],
 298                     CmmLit (mkIntCLit bLOCK_SIZE)
 299                    ])
 300                   (-1)
 301                 )
 302             )
 303    ]
 304
 305
 306 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 307 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 308 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 309
 310 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 311 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 312 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 313
 314 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 315 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 316 tsoFieldB :: ByteOff -> ByteOff
 317 tsoFieldB off
 318   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 319   | otherwise          = off + fixedHdrSize * wORD_SIZE
 320
 321 tsoProfFieldB :: ByteOff -> ByteOff
 322 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 323
 324 stgSp             = CmmReg sp
 325 stgHp             = CmmReg hp
 326 stgCurrentTSO     = CmmReg currentTSO
 327 stgCurrentNursery = CmmReg currentNursery
 328
 329 sp                = CmmGlobal Sp
 330 spLim             = CmmGlobal SpLim
 331 hp                = CmmGlobal Hp
 332 hpLim             = CmmGlobal HpLim
 333 currentTSO        = CmmGlobal CurrentTSO
 334 currentNursery    = CmmGlobal CurrentNursery
 335
 336 -----------------------------------------------------------------------------
 337 -- Functions that generate CmmStmt sequences
 338 -- for packing/unpacking continuations
 339 -- and entering/exiting functions
 340
 341 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 342 tail_call spRel target arguments
 343   = store_arguments ++ adjust_sp_reg spRel ++ jump where
 344     store_arguments =
 345         [stack_put spRel expr offset
 346          | ((expr, _), StackParam offset) <- argument_formats] ++
 347         [global_put expr global
 348          | ((expr, _), RegisterParam global) <- argument_formats]
 349     jump = [CmmJump target arguments]
 350
 351     argument_formats = assignArguments (cmmExprRep . fst) arguments
 352
 353 adjust_sp_reg spRel =
 354     if spRel == 0
 355     then []
 356     else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 357
 358 assign_gc_stack_use stack_use arg_stack max_frame_size =
 359     if max_frame_size > arg_stack
 360     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 361     else [CmmAssign stack_use (CmmReg spLimReg)]
 362          -- Trick the optimizer into eliminating the branch for us
 363
 364 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 365 gc_stack_check gc_block max_frame_size
 366   = check_stack_limit where
 367     check_stack_limit = [
 368      CmmCondBranch
 369      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 370                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 371                      CmmReg spLimReg])
 372      gc_block]
 373
 374
 375 pack_continuation :: Bool               -- ^ Whether to set the top/header
 376                                         -- of the stack.  We only need to
 377                                         -- set it if we are calling down
 378                                         -- as opposed to continuation
 379                                         -- adaptors.
 380                   -> ContinuationFormat -- ^ The current format
 381                   -> ContinuationFormat -- ^ The return point format
 382                   -> [CmmStmt]
 383 pack_continuation allow_header_set
 384                       (ContinuationFormat _ curr_id curr_frame_size _)
 385                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
 386   = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
 387   where
 388     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 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 Just continuation_function
 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))