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