compiler/cmm/CmmCPSGen.hs

   1 {-# OPTIONS_GHC -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
   6 -- for details
   7
   8 module CmmCPSGen (
   9   -- | Converts continuations into full proceedures.
  10   -- The main work of the CPS transform that everything else is setting-up.
  11   continuationToProc,
  12   Continuation(..), continuationLabel,
  13   ContinuationFormat(..),
  14 ) where
  15
  16 #include "HsVersions.h"
  17
  18 import Cmm
  19 import CLabel
  20 import CmmBrokenBlock -- Data types only
  21 import MachOp
  22 import CmmUtils
  23 import CmmCallConv
  24
  25 import CgProf
  26 import CgUtils
  27 import CgInfoTbls
  28 import SMRep
  29 import ForeignCall
  30
  31 import Constants
  32 import StaticFlags
  33 import Unique
  34 import Maybe
  35 import List
  36
  37 import Panic
  38
  39 -- The format for the call to a continuation
  40 -- The fst is the arguments that must be passed to the continuation
  41 -- by the continuation's caller.
  42 -- The snd is the live values that must be saved on stack.
  43 -- A Nothing indicates an ignored slot.
  44 -- The head of each list is the stack top or the first parameter.
  45
  46 -- The format for live values for a particular continuation
  47 -- All on stack for now.
  48 -- Head element is the top of the stack (or just under the header).
  49 -- Nothing means an empty slot.
  50 -- Future possibilities include callee save registers (i.e. passing slots in register)
  51 -- and heap memory (not sure if that's usefull at all though, but it may
  52 -- be worth exploring the design space).
  53
  54 continuationLabel (Continuation _ l _ _ _) = l
  55 data Continuation info =
  56   Continuation
  57      info              -- Left <=> Continuation created by the CPS
  58                        -- Right <=> Function or Proc point
  59      CLabel            -- Used to generate both info & entry labels
  60      CmmFormals        -- Argument locals live on entry (C-- procedure params)
  61      Bool              -- ^ True <=> GC block so ignore stack size
  62      [BrokenBlock]     -- Code, may be empty.  The first block is
  63                        -- the entry point.  The order is otherwise initially
  64                        -- unimportant, but at some point the code gen will
  65                        -- fix the order.
  66
  67                        -- the BlockId of the first block does not give rise
  68                        -- to a label.  To jump to the first block in a Proc,
  69                        -- use the appropriate CLabel.
  70
  71 data ContinuationFormat
  72     = ContinuationFormat {
  73         continuation_formals :: CmmFormals,
  74         continuation_label :: Maybe CLabel,     -- The label occupying the top slot
  75         continuation_frame_size :: WordOff,     -- Total frame size in words (not including arguments)
  76         continuation_stack :: [Maybe LocalReg]  -- local reg offsets from stack top
  77       }
  78
  79 -- A block can be a continuation of a call
  80 -- A block can be a continuation of another block (w/ or w/o joins)
  81 -- A block can be an entry to a function
  82
  83 -----------------------------------------------------------------------------
  84 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
  85                    -> CmmReg
  86                    -> [[[Unique]]]
  87                    -> Continuation CmmInfo
  88                    -> CmmTop
  89 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
  90                    (Continuation info label formals _ blocks) =
  91     CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
  92     where
  93       curr_format = maybe unknown_block id $ lookup label formats
  94       unknown_block = panic "unknown BlockId in continuationToProc"
  95       curr_stack = continuation_frame_size curr_format
  96       arg_stack = argumentsSize localRegRep formals
  97
  98       param_stmts :: [CmmStmt]
  99       param_stmts = function_entry curr_format
 100
 101       gc_stmts :: [CmmStmt]
 102       gc_stmts =
 103         assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
 104
 105       update_stmts :: [CmmStmt]
 106       update_stmts =
 107           case info of
 108             CmmInfo _ (Just (UpdateFrame target args)) _ ->
 109                 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
 110                 adjust_sp_reg (curr_stack - update_frame_size)
 111             CmmInfo _ Nothing _ -> []
 112
 113       continuationToProc' :: [[Unique]]
 114                           -> BrokenBlock
 115                           -> Bool
 116                           -> [CmmBasicBlock]
 117       continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
 118           prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
 119           where
 120             prefix_blocks =
 121                 if is_entry
 122                 then [BasicBlock
 123                       (BlockId prefix_unique)
 124                       (param_stmts ++ [CmmBranch ident])]
 125                 else []
 126
 127             (prefix_unique : call_uniques) : new_block_uniques = uniques
 128             toCLabel = mkReturnPtLabel . getUnique
 129
 130             block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
 131             block_for_branch unique next
 132                 -- branches to the current function don't have to jump
 133                 | (mkReturnPtLabel $ getUnique next) == label
 134                 = (next, [])
 135
 136                 -- branches to any other function have to jump
 137                 | (Just cont_format) <- lookup (toCLabel next) formats
 138                 = let
 139                     new_next = BlockId unique
 140                     cont_stack = continuation_frame_size cont_format
 141                     arguments = map formal_to_actual (continuation_formals cont_format)
 142                   in (new_next,
 143                      [BasicBlock new_next $
 144                       pack_continuation curr_format cont_format ++
 145                       tail_call (curr_stack - cont_stack)
 146                               (CmmLit $ CmmLabel $ toCLabel next)
 147                               arguments])
 148
 149                 -- branches to blocks in the current function don't have to jump
 150                 | otherwise
 151                 = (next, [])
 152
 153             -- Wrapper for block_for_branch for when the target
 154             -- is inside a 'Maybe'.
 155             block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
 156             block_for_branch' _ Nothing = (Nothing, [])
 157             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
 158               where (new_next, new_blocks) = block_for_branch unique next
 159
 160             -- If the target of a switch, branch or cond branch becomes a proc point
 161             -- then we have to make a new block what will then *jump* to the original target.
 162             proc_point_fix unique (CmmCondBranch test target)
 163                 = (CmmCondBranch test new_target, new_blocks)
 164                   where (new_target, new_blocks) = block_for_branch (head unique) target
 165             proc_point_fix unique (CmmSwitch test targets)
 166                 = (CmmSwitch test new_targets, concat new_blocks)
 167                   where (new_targets, new_blocks) =
 168                             unzip $ zipWith block_for_branch' unique targets
 169             proc_point_fix unique (CmmBranch target)
 170                 = (CmmBranch new_target, new_blocks)
 171                   where (new_target, new_blocks) = block_for_branch (head unique) target
 172             proc_point_fix _ other = (other, [])
 173
 174             (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
 175             main_stmts =
 176                 case entry of
 177                   FunctionEntry _ _ _ ->
 178                       -- Ugh, the statements for an update frame must come
 179                       -- *after* the GC check that was added at the beginning
 180                       -- of the CPS pass.  So we have do edit the statements
 181                       -- a bit.  This depends on the knowledge that the
 182                       -- statements in the first block are only the GC check.
 183                       -- That's fragile but it works for now.
 184                       gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
 185                   ControlEntry -> stmts ++ postfix_stmts
 186                   ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
 187             postfix_stmts = case exit of
 188                         -- Branches and switches may get modified by proc_point_fix
 189                         FinalBranch next -> [CmmBranch next]
 190                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 191
 192                         -- A return is a tail call to the stack top
 193                         FinalReturn arguments ->
 194                             tail_call curr_stack
 195                                 (entryCode (CmmLoad (CmmReg spReg) wordRep))
 196                                 arguments
 197
 198                         -- A tail call
 199                         FinalJump target arguments ->
 200                             tail_call curr_stack target arguments
 201
 202                         -- A regular Cmm function call
 203                         FinalCall next (CmmCallee target CmmCallConv)
 204                             results arguments _ _ _ ->
 205                                 pack_continuation curr_format cont_format ++
 206                                 tail_call (curr_stack - cont_stack)
 207                                               target arguments
 208                             where
 209                               cont_format = maybe unknown_block id $
 210                                             lookup (mkReturnPtLabel $ getUnique next) formats
 211                               cont_stack = continuation_frame_size cont_format
 212
 213                         -- A safe foreign call
 214                         FinalCall next (CmmCallee target conv)
 215                             results arguments _ _ _ ->
 216                                 target_stmts ++
 217                                 foreignCall call_uniques' (CmmCallee new_target conv)
 218                                             results arguments
 219                             where
 220                               (call_uniques', target_stmts, new_target) =
 221                                   maybeAssignTemp call_uniques target
 222
 223                         -- A safe prim call
 224                         FinalCall next (CmmPrim target)
 225                             results arguments _ _ _ ->
 226                                 foreignCall call_uniques (CmmPrim target)
 227                                             results arguments
 228
 229 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 230
 231 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
 232 foreignCall uniques call results arguments =
 233     arg_stmts ++
 234     saveThreadState ++
 235     caller_save ++
 236     [CmmCall (CmmCallee suspendThread CCallConv)
 237                  [ (id,PtrHint) ]
 238                  [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 239                  CmmUnsafe
 240                  CmmMayReturn,
 241      CmmCall call results new_args CmmUnsafe CmmMayReturn,
 242      CmmCall (CmmCallee resumeThread CCallConv)
 243                  [ (new_base, PtrHint) ]
 244                  [ (CmmReg (CmmLocal id), PtrHint) ]
 245                  CmmUnsafe
 246                  CmmMayReturn,
 247      -- Assign the result to BaseReg: we
 248      -- might now have a different Capability!
 249      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 250     caller_load ++
 251     loadThreadState tso_unique ++
 252     [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
 253     where
 254       (_, arg_stmts, new_args) =
 255           loadArgsIntoTemps argument_uniques arguments
 256       (caller_save, caller_load) =
 257           callerSaveVolatileRegs (Just [{-only system regs-}])
 258       new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
 259       id = LocalReg id_unique wordRep KindNonPtr
 260       tso_unique : base_unique : id_unique : argument_uniques = uniques
 261
 262 -- -----------------------------------------------------------------------------
 263 -- Save/restore the thread state in the TSO
 264
 265 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 266 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 267
 268 -- This stuff can't be done in suspendThread/resumeThread, because it
 269 -- refers to global registers which aren't available in the C world.
 270
 271 saveThreadState =
 272   -- CurrentTSO->sp = Sp;
 273   [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
 274   closeNursery] ++
 275   -- and save the current cost centre stack in the TSO when profiling:
 276   if opt_SccProfilingOn
 277   then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
 278   else []
 279
 280    -- CurrentNursery->free = Hp+1;
 281 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 282
 283 loadThreadState tso_unique =
 284   [
 285         -- tso = CurrentTSO;
 286         CmmAssign (CmmLocal tso) stgCurrentTSO,
 287         -- Sp = tso->sp;
 288         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 289                               wordRep),
 290         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 291         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 292                                     rESERVED_STACK_WORDS)
 293   ] ++
 294   openNursery ++
 295   -- and load the current cost centre stack from the TSO when profiling:
 296   if opt_SccProfilingOn
 297   then [CmmStore curCCSAddr
 298         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
 299   else []
 300   where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
 301
 302
 303 openNursery = [
 304         -- Hp = CurrentNursery->free - 1;
 305         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 306
 307         -- HpLim = CurrentNursery->start +
 308         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 309         CmmAssign hpLim
 310             (cmmOffsetExpr
 311                 (CmmLoad nursery_bdescr_start wordRep)
 312                 (cmmOffset
 313                   (CmmMachOp mo_wordMul [
 314                     CmmMachOp (MO_S_Conv I32 wordRep)
 315                       [CmmLoad nursery_bdescr_blocks I32],
 316                     CmmLit (mkIntCLit bLOCK_SIZE)
 317                    ])
 318                   (-1)
 319                 )
 320             )
 321    ]
 322
 323
 324 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 325 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 326 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 327
 328 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 329 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 330 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 331
 332 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 333 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 334 tsoFieldB :: ByteOff -> ByteOff
 335 tsoFieldB off
 336   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 337   | otherwise          = off + fixedHdrSize * wORD_SIZE
 338
 339 tsoProfFieldB :: ByteOff -> ByteOff
 340 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 341
 342 stgSp             = CmmReg sp
 343 stgHp             = CmmReg hp
 344 stgCurrentTSO     = CmmReg currentTSO
 345 stgCurrentNursery = CmmReg currentNursery
 346
 347 sp                = CmmGlobal Sp
 348 spLim             = CmmGlobal SpLim
 349 hp                = CmmGlobal Hp
 350 hpLim             = CmmGlobal HpLim
 351 currentTSO        = CmmGlobal CurrentTSO
 352 currentNursery    = CmmGlobal CurrentNursery
 353
 354 -----------------------------------------------------------------------------
 355 -- Functions that generate CmmStmt sequences
 356 -- for packing/unpacking continuations
 357 -- and entering/exiting functions
 358
 359 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 360 tail_call spRel target arguments
 361   = store_arguments ++ adjust_sp_reg spRel ++ jump where
 362     store_arguments =
 363         [stack_put spRel expr offset
 364          | ((expr, _), StackParam offset) <- argument_formats] ++
 365         [global_put expr global
 366          | ((expr, _), RegisterParam global) <- argument_formats]
 367     jump = [CmmJump target arguments]
 368
 369     argument_formats = assignArguments (cmmExprRep . fst) arguments
 370
 371 adjust_sp_reg spRel =
 372     if spRel == 0
 373     then []
 374     else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 375
 376 assign_gc_stack_use stack_use arg_stack max_frame_size =
 377     if max_frame_size > arg_stack
 378     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 379     else [CmmAssign stack_use (CmmReg spLimReg)]
 380          -- Trick the optimizer into eliminating the branch for us
 381
 382 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 383 gc_stack_check gc_block max_frame_size
 384   = check_stack_limit where
 385     check_stack_limit = [
 386      CmmCondBranch
 387      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 388                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 389                      CmmReg spLimReg])
 390      gc_block]
 391
 392
 393 pack_continuation :: ContinuationFormat -- ^ The current format
 394                   -> ContinuationFormat -- ^ The return point format
 395                   -> [CmmStmt]
 396 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
 397                   (ContinuationFormat _ cont_id cont_frame_size live_regs)
 398   = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
 399   where
 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 needs_header_set
 408                    then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
 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))