compiler/codeGen/StgCmmExpr.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C-- code generation: expressions
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmExpr ( cgExpr ) where
  10
  11 #define FAST_STRING_NOT_NEEDED
  12 #include "HsVersions.h"
  13
  14 import {-# SOURCE #-} StgCmmBind ( cgBind )
  15
  16 import StgCmmMonad
  17 import StgCmmHeap
  18 import StgCmmEnv
  19 import StgCmmCon
  20 import StgCmmProf
  21 import StgCmmLayout
  22 import StgCmmPrim
  23 import StgCmmHpc
  24 import StgCmmTicky
  25 import StgCmmUtils
  26 import StgCmmClosure
  27
  28 import StgSyn
  29
  30 import MkZipCfgCmm
  31 import BlockId
  32 import Cmm()
  33 import CmmExpr
  34 import CoreSyn
  35 import DataCon
  36 import ForeignCall
  37 import Id
  38 import PrimOp
  39 import TyCon
  40 import CostCentre       ( CostCentreStack, currentCCS )
  41 import Maybes
  42 import Util
  43 import FastString
  44 import Outputable
  45
  46 ------------------------------------------------------------------------
  47 --              cgExpr: the main function
  48 ------------------------------------------------------------------------
  49
  50 cgExpr  :: StgExpr -> FCode ()
  51
  52 cgExpr (StgApp fun args)     = cgIdApp fun args
  53 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
  54 cgExpr (StgConApp con args)  = cgConApp con args
  55 cgExpr (StgSCC cc expr)   = do { emitSetCCC cc; cgExpr expr }
  56 cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
  57 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
  58                                emitReturn [CmmLit cmm_lit]
  59
  60 cgExpr (StgLet binds expr)             = do { cgBind binds; cgExpr expr }
  61 cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
  62
  63 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
  64   cgCase expr bndr srt alt_type alts
  65
  66 cgExpr (StgLam {}) = panic "cgExpr: StgLam"
  67
  68 ------------------------------------------------------------------------
  69 --              Let no escape
  70 ------------------------------------------------------------------------
  71
  72 {- Generating code for a let-no-escape binding, aka join point is very
  73 very similar to what we do for a case expression.  The duality is
  74 between
  75         let-no-escape x = b
  76         in e
  77 and
  78         case e of ... -> b
  79
  80 That is, the RHS of 'x' (ie 'b') will execute *later*, just like
  81 the alternative of the case; it needs to be compiled in an environment
  82 in which all volatile bindings are forgotten, and the free vars are
  83 bound only to stable things like stack locations..  The 'e' part will
  84 execute *next*, just like the scrutinee of a case. -}
  85
  86 -------------------------
  87 cgLneBinds :: StgBinding -> FCode ()
  88 cgLneBinds (StgNonRec bndr rhs)
  89   = do  { local_cc <- saveCurrentCostCentre
  90                 -- See Note [Saving the current cost centre]
  91         ; info <- cgLetNoEscapeRhs local_cc bndr rhs
  92         ; addBindC (cg_id info) info }
  93
  94 cgLneBinds (StgRec pairs)
  95   = do  { local_cc <- saveCurrentCostCentre
  96         ; new_bindings <- fixC (\ new_bindings -> do
  97                 { addBindsC new_bindings
  98                 ; listFCs [ cgLetNoEscapeRhs local_cc b e
  99                           | (b,e) <- pairs ] })
 100
 101         ; addBindsC new_bindings }
 102
 103
 104 -------------------------
 105 cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
 106     :: Maybe LocalReg   -- Saved cost centre
 107     -> Id
 108     -> StgRhs
 109     -> FCode CgIdInfo
 110
 111 cgLetNoEscapeRhs local_cc bndr rhs =
 112   do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
 113      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
 114      ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
 115      ; return info
 116      }
 117
 118 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
 119   = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
 120 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
 121   = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
 122         -- For a constructor RHS we want to generate a single chunk of
 123         -- code which can be jumped to from many places, which will
 124         -- return the constructor. It's easy; just behave as if it
 125         -- was an StgRhsClosure with a ConApp inside!
 126
 127 -------------------------
 128 cgLetNoEscapeClosure
 129         :: Id                   -- binder
 130         -> Maybe LocalReg       -- Slot for saved current cost centre
 131         -> CostCentreStack      -- XXX: *** NOT USED *** why not?
 132         -> SRT
 133         -> [NonVoid Id]         -- Args (as in \ args -> body)
 134         -> StgExpr              -- Body (as in above)
 135         -> FCode CgIdInfo
 136
 137 cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
 138   = do  { arg_regs <- forkProc $ do
 139                 { restoreCurrentCostCentre cc_slot
 140                 ; arg_regs <- bindArgsToRegs args
 141                 ; c_srt <- getSRTInfo srt
 142                 ; altHeapCheck arg_regs c_srt (cgExpr body)
 143                         -- Using altHeapCheck just reduces
 144                         -- instructions to save on stack
 145                 ; return arg_regs }
 146         ; return $ lneIdInfo bndr arg_regs}
 147
 148
 149 ------------------------------------------------------------------------
 150 --              Case expressions
 151 ------------------------------------------------------------------------
 152
 153 {- Note [Compiling case expressions]
 154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 155 It is quite interesting to decide whether to put a heap-check at the
 156 start of each alternative.  Of course we certainly have to do so if
 157 the case forces an evaluation, or if there is a primitive op which can
 158 trigger GC.
 159
 160 A more interesting situation is this (a Plan-B situation)
 161
 162         !P!;
 163         ...P...
 164         case x# of
 165           0#      -> !Q!; ...Q...
 166           default -> !R!; ...R...
 167
 168 where !x! indicates a possible heap-check point. The heap checks
 169 in the alternatives *can* be omitted, in which case the topmost
 170 heapcheck will take their worst case into account.
 171
 172 In favour of omitting !Q!, !R!:
 173
 174  - *May* save a heap overflow test,
 175    if ...P... allocates anything.
 176
 177  - We can use relative addressing from a single Hp to
 178    get at all the closures so allocated.
 179
 180  - No need to save volatile vars etc across heap checks
 181    in !Q!, !R!
 182
 183 Against omitting !Q!, !R!
 184
 185   - May put a heap-check into the inner loop.  Suppose
 186         the main loop is P -> R -> P -> R...
 187         Q is the loop exit, and only it does allocation.
 188     This only hurts us if P does no allocation.  If P allocates,
 189     then there is a heap check in the inner loop anyway.
 190
 191   - May do more allocation than reqd.  This sometimes bites us
 192     badly.  For example, nfib (ha!) allocates about 30\% more space if the
 193     worst-casing is done, because many many calls to nfib are leaf calls
 194     which don't need to allocate anything.
 195
 196     We can un-allocate, but that costs an instruction
 197
 198 Neither problem hurts us if there is only one alternative.
 199
 200 Suppose the inner loop is P->R->P->R etc.  Then here is
 201 how many heap checks we get in the *inner loop* under various
 202 conditions
 203
 204   Alooc   Heap check in branches (!Q!, !R!)?
 205   P Q R      yes     no (absorb to !P!)
 206 --------------------------------------
 207   n n n      0          0
 208   n y n      0          1
 209   n . y      1          1
 210   y . y      2          1
 211   y . n      1          1
 212
 213 Best choices: absorb heap checks from Q and R into !P! iff
 214   a) P itself does some allocation
 215 or
 216   b) P does allocation, or there is exactly one alternative
 217
 218 We adopt (b) because that is more likely to put the heap check at the
 219 entry to a function, when not many things are live.  After a bunch of
 220 single-branch cases, we may have lots of things live
 221
 222 Hence: two basic plans for
 223
 224         case e of r { alts }
 225
 226 ------ Plan A: the general case ---------
 227
 228         ...save current cost centre...
 229
 230         ...code for e,
 231            with sequel (SetLocals r)
 232
 233         ...restore current cost centre...
 234         ...code for alts...
 235         ...alts do their own heap checks
 236
 237 ------ Plan B: special case when ---------
 238   (i)  e does not allocate or call GC
 239   (ii) either upstream code performs allocation
 240        or there is just one alternative
 241
 242   Then heap allocation in the (single) case branch
 243   is absorbed by the upstream check.
 244   Very common example: primops on unboxed values
 245
 246         ...code for e,
 247            with sequel (SetLocals r)...
 248
 249         ...code for alts...
 250         ...no heap check...
 251 -}
 252
 253
 254
 255 -------------------------------------
 256 data GcPlan
 257   = GcInAlts            -- Put a GC check at the start the case alternatives,
 258         [LocalReg]      -- which binds these registers
 259         SRT             -- using this SRT
 260   | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a
 261                         -- primitive op which does no GC.  Absorb the allocation
 262                         -- of the case alternative(s) into the upstream check
 263
 264 -------------------------------------
 265 cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
 266 -- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
 267   -- | isBoolTy (idType bndr)
 268   -- , isDeadBndr bndr
 269   -- =
 270
 271 cgCase scrut bndr srt alt_type alts
 272   = do  { up_hp_usg <- getVirtHp        -- Upstream heap usage
 273         ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
 274               alt_regs  = map idToReg ret_bndrs
 275               simple_scrut = isSimpleScrut scrut alt_type
 276               gc_plan | not simple_scrut = GcInAlts alt_regs srt
 277                       | isSingleton alts = NoGcInAlts
 278                       | up_hp_usg > 0    = NoGcInAlts
 279                       | otherwise        = GcInAlts alt_regs srt
 280
 281         ; mb_cc <- maybeSaveCostCentre simple_scrut
 282         ; c_srt <- getSRTInfo srt
 283         ; withSequel (AssignTo alt_regs c_srt)
 284                      (cgExpr scrut)
 285         ; restoreCurrentCostCentre mb_cc
 286
 287         ; bindArgsToRegs ret_bndrs
 288         ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
 289
 290 -----------------
 291 maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
 292 maybeSaveCostCentre simple_scrut
 293   | simple_scrut = saveCurrentCostCentre
 294   | otherwise    = return Nothing
 295
 296
 297 -----------------
 298 isSimpleScrut :: StgExpr -> AltType -> Bool
 299 -- Simple scrutinee, does not block or allocate; hence safe to amalgamate
 300 -- heap usage from alternatives into the stuff before the case
 301 -- NB: if you get this wrong, and claim that the expression doesn't allocate
 302 --     when it does, you'll deeply mess up allocation
 303 isSimpleScrut (StgOpApp op _ _) _          = isSimpleOp op
 304 isSimpleScrut (StgLit _)       _           = True       -- case 1# of { 0# -> ..; ... }
 305 isSimpleScrut (StgApp _ [])    (PrimAlt _) = True       -- case x# of { 0# -> ..; ... }
 306 isSimpleScrut _                _           = False
 307
 308 isSimpleOp :: StgOp -> Bool
 309 -- True iff the op cannot block or allocate
 310 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
 311 isSimpleOp (StgFCallOp (DNCall _) _)                   = False         -- Safe!
 312 isSimpleOp (StgPrimOp op)                              = not (primOpOutOfLine op)
 313
 314 -----------------
 315 chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
 316 -- These are the binders of a case that are assigned
 317 -- by the evaluation of the scrutinee
 318 -- Only non-void ones come back
 319 chooseReturnBndrs bndr (PrimAlt _) _alts
 320   = nonVoidIds [bndr]
 321
 322 chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)]
 323   = nonVoidIds ids      -- 'bndr' is not assigned!
 324
 325 chooseReturnBndrs bndr (AlgAlt _) _alts
 326   = nonVoidIds [bndr]   -- Only 'bndr' is assigned
 327
 328 chooseReturnBndrs bndr PolyAlt _alts
 329   = nonVoidIds [bndr]   -- Only 'bndr' is assigned
 330
 331 chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
 332         -- UbxTupALt has only one alternative
 333
 334 -------------------------------------
 335 cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode ()
 336 -- At this point the result of the case are in the binders
 337 cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)]
 338   = maybeAltHeapCheck gc_plan (cgExpr rhs)
 339
 340 cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)]
 341   = maybeAltHeapCheck gc_plan (cgExpr rhs)
 342         -- Here bndrs are *already* in scope, so don't rebind them
 343
 344 cgAlts gc_plan bndr (PrimAlt _) alts
 345   = do  { tagged_cmms <- cgAltRhss gc_plan bndr alts
 346
 347         ; let bndr_reg = CmmLocal (idToReg bndr)
 348               (DEFAULT,deflt) = head tagged_cmms
 349                 -- PrimAlts always have a DEFAULT case
 350                 -- and it always comes first
 351
 352               tagged_cmms' = [(lit,code)
 353                              | (LitAlt lit, code) <- tagged_cmms]
 354         ; emit (mkCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt) }
 355
 356 cgAlts gc_plan bndr (AlgAlt tycon) alts
 357   = do  { tagged_cmms <- cgAltRhss gc_plan bndr alts
 358
 359         ; let fam_sz   = tyConFamilySize tycon
 360               bndr_reg = CmmLocal (idToReg bndr)
 361               mb_deflt = case tagged_cmms of
 362                            ((DEFAULT,rhs) : _) -> Just rhs
 363                            _other              -> Nothing
 364                 -- DEFAULT is always first, if present
 365
 366               branches = [ (dataConTagZ con, cmm)
 367                          | (DataAlt con, cmm) <- tagged_cmms ]
 368
 369                     -- Is the constructor tag in the node reg?
 370         ; if isSmallFamily fam_sz
 371           then let      -- Yes, bndr_reg has constr. tag in ls bits
 372                    tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
 373                    branches' = [(tag+1,branch) | (tag,branch) <- branches]
 374                 in
 375                 emitSwitch tag_expr branches' mb_deflt 1 fam_sz
 376
 377            else         -- No, get tag from info table
 378                 let -- Note that ptr _always_ has tag 1
 379                     -- when the family size is big enough
 380                     untagged_ptr = cmmRegOffB bndr_reg (-1)
 381                     tag_expr = getConstrTag (untagged_ptr)
 382                  in
 383                  emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) }
 384
 385 cgAlts _ _ _ _ = panic "cgAlts"
 386         -- UbxTupAlt and PolyAlt have only one alternative
 387
 388 -------------------
 389 cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
 390 cgAltRhss gc_plan bndr alts
 391   = forkAlts (map cg_alt alts)
 392   where
 393     base_reg = idToReg bndr
 394     cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph)
 395     cg_alt (con, bndrs, _uses, rhs)
 396       = getCodeR                  $
 397         maybeAltHeapCheck gc_plan $
 398         do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs
 399            ; cgExpr rhs
 400            ; return con }
 401
 402 maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
 403 maybeAltHeapCheck NoGcInAlts code
 404   = code
 405 maybeAltHeapCheck (GcInAlts regs srt) code
 406   = do  { c_srt <- getSRTInfo srt
 407         ; altHeapCheck regs c_srt code }
 408
 409 -----------------------------------------------------------------------------
 410 --      Tail calls
 411 -----------------------------------------------------------------------------
 412
 413 cgConApp :: DataCon -> [StgArg] -> FCode ()
 414 cgConApp con stg_args
 415   | isUnboxedTupleCon con       -- Unboxed tuple: assign and return
 416   = do { arg_exprs <- getNonVoidArgAmodes stg_args
 417        ; tickyUnboxedTupleReturn (length arg_exprs)
 418        ; emitReturn arg_exprs }
 419
 420   | otherwise   --  Boxed constructors; allocate and return
 421   = ASSERT( stg_args `lengthIs` dataConRepArity con )
 422     do  { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
 423                 -- The first "con" says that the name bound to this closure is
 424                 -- is "con", which is a bit of a fudge, but it only affects profiling
 425
 426         ; emit init
 427         ; emitReturn [idInfoToAmode idinfo] }
 428
 429
 430 cgIdApp :: Id -> [StgArg] -> FCode ()
 431 cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
 432 cgIdApp fun_id args
 433   = do  { fun_info <- getCgIdInfo fun_id
 434         ; case maybeLetNoEscape fun_info of
 435             Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
 436             Nothing -> cgTailCall fun_id fun_info args }
 437
 438 cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
 439 cgLneJump blk_id lne_regs args  -- Join point; discard sequel
 440   = do  { cmm_args <- getNonVoidArgAmodes args
 441         ; emit (mkMultiAssign lne_regs cmm_args
 442                 <*> mkBranch blk_id) }
 443
 444 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
 445 cgTailCall fun_id fun_info args
 446   = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
 447
 448             -- A value in WHNF, so we can just return it.
 449         ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
 450
 451         EnterIt -> ASSERT( null args )  -- Discarding arguments
 452                 do { let fun' = CmmLoad fun (cmmExprType fun)
 453                    ; [ret,call] <- forkAlts [
 454                         getCode $ emitReturn [fun],     -- Is tagged; no need to untag
 455                         getCode $ do emit (mkAssign nodeReg fun)
 456                                      emitCall Native (entryCode fun') []]  -- Not tagged
 457                    ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
 458
 459         SlowCall -> do      -- A slow function call via the RTS apply routines
 460                 { tickySlowCall lf_info args
 461                 ; emit $ mkComment $ mkFastString "slowCall"
 462                 ; slowCall fun args }
 463
 464         -- A direct function call (possibly with some left-over arguments)
 465         DirectEntry lbl arity -> do
 466                 { tickyDirectCall arity args
 467                 ; if node_points then
 468                     do emit $ mkComment $ mkFastString "directEntry"
 469                        emit (mkAssign nodeReg fun)
 470                        directCall lbl arity args
 471                     -- directCall lbl (arity+1) (StgVarArg fun_id : args))
 472                     -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>))
 473                   else do emit $ mkComment $ mkFastString "directEntry else"
 474                           directCall lbl arity args }
 475
 476         JumpToIt {} -> panic "cgTailCall"       -- ???
 477
 478   where
 479     fun_name    = idName            fun_id
 480     fun         = idInfoToAmode     fun_info
 481     lf_info     = cgIdInfoLF        fun_info
 482     node_points = nodeMustPointToIt lf_info
 483
 484
 485