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, [(CLabel, ContinuationFormat)])
  82                    -> CmmReg
  83                    -> [[Unique]]
  84                    -> Continuation CmmInfo
  85                    -> CmmTop
  86 continuationToProc (max_stack, 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             CmmNonInfo (Just gc_block) ->
 106                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
 107             CmmNonInfo Nothing ->
 108                 panic "continuationToProc: missing non-info GC block"
 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                 case gc_prefix ++ param_prefix of
 124                   [] -> []
 125                   entry_stmts -> [BasicBlock prefix_id
 126                                   (entry_stmts ++ [CmmBranch ident])]
 127
 128             prefix_unique : call_uniques = uniques
 129             toCLabel = mkReturnPtLabel . getUnique
 130
 131             block_for_branch unique next
 132                 | (Just cont_format) <- lookup (toCLabel next) formats
 133                 = let
 134                     new_next = BlockId unique
 135                     cont_stack = continuation_frame_size cont_format
 136                     arguments = map formal_to_actual (continuation_formals cont_format)
 137                   in (new_next,
 138                      [BasicBlock new_next $
 139                       pack_continuation False curr_format cont_format ++
 140                       tail_call (curr_stack - cont_stack)
 141                               (CmmLit $ CmmLabel $ toCLabel next)
 142                               arguments])
 143                 | otherwise
 144                 = (next, [])
 145
 146             block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
 147             block_for_branch' _ Nothing = (Nothing, [])
 148             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
 149               where (new_next, new_blocks) = block_for_branch unique next
 150
 151             main_block = BasicBlock ident (stmts ++ postfix_stmts)
 152             prefix_id = BlockId prefix_unique
 153             gc_prefix = case entry of
 154                        FunctionEntry _ _ _ -> gc_stmts
 155                        ControlEntry -> []
 156                        ContinuationEntry _ _ _ -> []
 157             param_prefix = if is_entry
 158                            then param_stmts
 159                            else []
 160             postfix_stmts = case exit of
 161                         FinalBranch next ->
 162                             if (mkReturnPtLabel $ getUnique next) == label
 163                             then [CmmBranch next]
 164                             else case lookup (mkReturnPtLabel $ getUnique next) formats of
 165                               Nothing -> [CmmBranch next]
 166                               Just cont_format ->
 167                                 pack_continuation False curr_format cont_format ++
 168                                 tail_call (curr_stack - cont_stack)
 169                                           (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
 170                                           arguments
 171                                 where
 172                                   cont_stack = continuation_frame_size cont_format
 173                                   arguments = map formal_to_actual (continuation_formals cont_format)
 174                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 175                         FinalReturn arguments ->
 176                             tail_call curr_stack
 177                                 (CmmLoad (CmmReg spReg) wordRep)
 178                                 arguments
 179                         FinalJump target arguments ->
 180                             tail_call curr_stack target arguments
 181
 182                         -- A regular Cmm function call
 183                         FinalCall next (CmmForeignCall target CmmCallConv)
 184                             results arguments _ _ ->
 185                                 pack_continuation True curr_format cont_format ++
 186                                 tail_call (curr_stack - cont_stack)
 187                                               target arguments
 188                             where
 189                               cont_format = maybe unknown_block id $
 190                                             lookup (mkReturnPtLabel $ getUnique next) formats
 191                               cont_stack = continuation_frame_size cont_format
 192
 193                         -- A safe foreign call
 194                         FinalCall next (CmmForeignCall target conv)
 195                             results arguments _ _ ->
 196                                 target_stmts ++
 197                                 foreignCall call_uniques' (CmmForeignCall new_target conv)
 198                                             results arguments
 199                             where
 200                               (call_uniques', target_stmts, new_target) =
 201                                   maybeAssignTemp call_uniques target
 202
 203                         -- A safe prim call
 204                         FinalCall next (CmmPrim target)
 205                             results arguments _ _ ->
 206                                 foreignCall call_uniques (CmmPrim target)
 207                                             results arguments
 208
 209 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 210
 211 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
 212 foreignCall uniques call results arguments =
 213     arg_stmts ++
 214     saveThreadState ++
 215     caller_save ++
 216     [CmmCall (CmmForeignCall suspendThread CCallConv)
 217                  [ (id,PtrHint) ]
 218                  [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 219                  CmmUnsafe,
 220      CmmCall call results new_args CmmUnsafe,
 221      CmmCall (CmmForeignCall resumeThread CCallConv)
 222                  [ (new_base, PtrHint) ]
 223                  [ (CmmReg (CmmLocal id), PtrHint) ]
 224                  CmmUnsafe,
 225      -- Assign the result to BaseReg: we
 226      -- might now have a different Capability!
 227      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 228     caller_load ++
 229     loadThreadState tso_unique ++
 230     [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
 231     where
 232       (_, arg_stmts, new_args) =
 233           loadArgsIntoTemps argument_uniques arguments
 234       (caller_save, caller_load) =
 235           callerSaveVolatileRegs (Just [{-only system regs-}])
 236       new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
 237       id = LocalReg id_unique wordRep KindNonPtr
 238       tso_unique : base_unique : id_unique : argument_uniques = uniques
 239
 240 -- -----------------------------------------------------------------------------
 241 -- Save/restore the thread state in the TSO
 242
 243 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 244 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 245
 246 -- This stuff can't be done in suspendThread/resumeThread, because it
 247 -- refers to global registers which aren't available in the C world.
 248
 249 saveThreadState =
 250   -- CurrentTSO->sp = Sp;
 251   [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
 252   closeNursery] ++
 253   -- and save the current cost centre stack in the TSO when profiling:
 254   if opt_SccProfilingOn
 255   then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
 256   else []
 257
 258    -- CurrentNursery->free = Hp+1;
 259 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 260
 261 loadThreadState tso_unique =
 262   [
 263         -- tso = CurrentTSO;
 264         CmmAssign (CmmLocal tso) stgCurrentTSO,
 265         -- Sp = tso->sp;
 266         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 267                               wordRep),
 268         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 269         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 270                                     rESERVED_STACK_WORDS)
 271   ] ++
 272   openNursery ++
 273   -- and load the current cost centre stack from the TSO when profiling:
 274   if opt_SccProfilingOn
 275   then [CmmStore curCCSAddr
 276         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
 277   else []
 278   where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
 279
 280
 281 openNursery = [
 282         -- Hp = CurrentNursery->free - 1;
 283         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 284
 285         -- HpLim = CurrentNursery->start +
 286         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 287         CmmAssign hpLim
 288             (cmmOffsetExpr
 289                 (CmmLoad nursery_bdescr_start wordRep)
 290                 (cmmOffset
 291                   (CmmMachOp mo_wordMul [
 292                     CmmMachOp (MO_S_Conv I32 wordRep)
 293                       [CmmLoad nursery_bdescr_blocks I32],
 294                     CmmLit (mkIntCLit bLOCK_SIZE)
 295                    ])
 296                   (-1)
 297                 )
 298             )
 299    ]
 300
 301
 302 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 303 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 304 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 305
 306 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 307 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 308 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 309
 310 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 311 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 312 tsoFieldB :: ByteOff -> ByteOff
 313 tsoFieldB off
 314   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 315   | otherwise          = off + fixedHdrSize * wORD_SIZE
 316
 317 tsoProfFieldB :: ByteOff -> ByteOff
 318 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 319
 320 stgSp             = CmmReg sp
 321 stgHp             = CmmReg hp
 322 stgCurrentTSO     = CmmReg currentTSO
 323 stgCurrentNursery = CmmReg currentNursery
 324
 325 sp                = CmmGlobal Sp
 326 spLim             = CmmGlobal SpLim
 327 hp                = CmmGlobal Hp
 328 hpLim             = CmmGlobal HpLim
 329 currentTSO        = CmmGlobal CurrentTSO
 330 currentNursery    = CmmGlobal CurrentNursery
 331
 332 -----------------------------------------------------------------------------
 333 -- Functions that generate CmmStmt sequences
 334 -- for packing/unpacking continuations
 335 -- and entering/exiting functions
 336
 337 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 338 tail_call spRel target arguments
 339   = store_arguments ++ adjust_spReg ++ jump where
 340     store_arguments =
 341         [stack_put spRel expr offset
 342          | ((expr, _), StackParam offset) <- argument_formats] ++
 343         [global_put expr global
 344          | ((expr, _), RegisterParam global) <- argument_formats]
 345     adjust_spReg =
 346         if spRel == 0
 347         then []
 348         else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 349     jump = [CmmJump target arguments]
 350
 351     argument_formats = assignArguments (cmmExprRep . fst) arguments
 352
 353 gc_stack_check' stack_use arg_stack max_frame_size =
 354     if max_frame_size > arg_stack
 355     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 356     else [CmmAssign stack_use (CmmReg spLimReg)]
 357          -- Trick the optimizer into eliminating the branch for us
 358
 359 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 360 gc_stack_check gc_block max_frame_size
 361   = check_stack_limit where
 362     check_stack_limit = [
 363      CmmCondBranch
 364      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 365                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 366                      CmmReg spLimReg])
 367      gc_block]
 368
 369
 370 -- TODO: fix branches to proc point
 371 -- (we have to insert a new block to marshel the continuation)
 372
 373
 374 pack_continuation :: Bool               -- ^ Whether to set the top/header
 375                                         -- of the stack.  We only need to
 376                                         -- set it if we are calling down
 377                                         -- as opposed to continuation
 378                                         -- adaptors.
 379                   -> ContinuationFormat -- ^ The current format
 380                   -> ContinuationFormat -- ^ The return point format
 381                   -> [CmmStmt]
 382 pack_continuation allow_header_set
 383                       (ContinuationFormat _ curr_id curr_frame_size _)
 384                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
 385   = store_live_values ++ set_stack_header where
 386     -- TODO: only save variables when actually needed
 387     -- (may be handled by latter pass)
 388     store_live_values =
 389         [stack_put spRel (CmmReg (CmmLocal reg)) offset
 390          | (reg, offset) <- cont_offsets]
 391     set_stack_header =
 392         if needs_header_set && allow_header_set
 393         then [stack_put spRel continuation_function 0]
 394         else []
 395
 396     -- TODO: factor with function_entry and CmmInfo.hs(?)
 397     cont_offsets = mkOffsets label_size live_regs
 398
 399     label_size = 1 :: WordOff
 400
 401     mkOffsets size [] = []
 402     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 403     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 404         where
 405           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 406           -- TODO: it would be better if we had a machRepWordWidth
 407
 408     spRel = curr_frame_size - cont_frame_size
 409     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 410     needs_header_set =
 411         case (curr_id, cont_id) of
 412           (Just x, Just y) -> x /= y
 413           _ -> isJust cont_id
 414
 415 -- Lazy adjustment of stack headers assumes all blocks
 416 -- that could branch to eachother (i.e. control blocks)
 417 -- have the same stack format (this causes a problem
 418 -- only for proc-point).
 419 function_entry :: ContinuationFormat -> [CmmStmt]
 420 function_entry (ContinuationFormat formals _ _ live_regs)
 421   = load_live_values ++ load_args where
 422     -- TODO: only save variables when actually needed
 423     -- (may be handled by latter pass)
 424     load_live_values =
 425         [stack_get 0 reg offset
 426          | (reg, offset) <- curr_offsets]
 427     load_args =
 428         [stack_get 0 reg offset
 429          | (reg, StackParam offset) <- argument_formats] ++
 430         [global_get reg global
 431          | (reg, RegisterParam global) <- argument_formats]
 432
 433     argument_formats = assignArguments (localRegRep) formals
 434
 435     -- TODO: eliminate copy/paste with pack_continuation
 436     curr_offsets = mkOffsets label_size live_regs
 437
 438     label_size = 1 :: WordOff
 439
 440     mkOffsets size [] = []
 441     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 442     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 443         where
 444           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 445           -- TODO: it would be better if we had a machRepWordWidth
 446
 447 -----------------------------------------------------------------------------
 448 -- Section: Stack and argument register puts and gets
 449 -----------------------------------------------------------------------------
 450 -- TODO: document
 451
 452 -- |Construct a 'CmmStmt' that will save a value on the stack
 453 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 454                                 -- is relative to (added to offset)
 455           -> CmmExpr            -- ^ What to store onto the stack
 456           -> WordOff            -- ^ Where on the stack to store it
 457                                 -- (positive <=> higher addresses)
 458           -> CmmStmt
 459 stack_put spRel expr offset =
 460     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 461
 462 --------------------------------
 463 -- |Construct a
 464 stack_get :: WordOff
 465           -> LocalReg
 466           -> WordOff
 467           -> CmmStmt
 468 stack_get spRel reg offset =
 469     CmmAssign (CmmLocal reg)
 470               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 471                        (localRegRep reg))
 472 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 473 global_put expr global = CmmAssign (CmmGlobal global) expr
 474 global_get :: LocalReg -> GlobalReg -> CmmStmt
 475 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))