compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 \begin{code}
   7 module CgExpr ( cgExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Constants
  12 import StgSyn
  13 import CgMonad
  14
  15 import SMRep
  16 import CoreSyn
  17 import CgProf
  18 import CgHeapery
  19 import CgBindery
  20 import CgCase
  21 import CgClosure
  22 import CgCon
  23 import CgLetNoEscape
  24 import CgCallConv
  25 import CgTailCall
  26 import CgInfoTbls
  27 import CgForeignCall
  28 import CgPrimOp
  29 import CgHpc
  30 import CgUtils
  31 import ClosureInfo
  32 import Cmm
  33 import MachOp
  34 import VarSet
  35 import Literal
  36 import PrimOp
  37 import Id
  38 import TyCon
  39 import Type
  40 import Maybes
  41 import ListSetOps
  42 import BasicTypes
  43 import Util
  44 import Outputable
  45 \end{code}
  46
  47 This module provides the support code for @StgToAbstractC@ to deal
  48 with STG {\em expressions}.  See also @CgClosure@, which deals
  49 with closures, and @CgCon@, which deals with constructors.
  50
  51 \begin{code}
  52 cgExpr  :: StgExpr              -- input
  53         -> Code                 -- output
  54 \end{code}
  55
  56 %********************************************************
  57 %*                                                      *
  58 %*              Tail calls                              *
  59 %*                                                      *
  60 %********************************************************
  61
  62 ``Applications'' mean {\em tail calls}, a service provided by module
  63 @CgTailCall@.  This includes literals, which show up as
  64 @(STGApp (StgLitArg 42) [])@.
  65
  66 \begin{code}
  67 cgExpr (StgApp fun args) = cgTailCall fun args
  68 \end{code}
  69
  70 %********************************************************
  71 %*                                                      *
  72 %*              STG ConApps  (for inline versions)      *
  73 %*                                                      *
  74 %********************************************************
  75
  76 \begin{code}
  77 cgExpr (StgConApp con args)
  78   = do  { amodes <- getArgAmodes args
  79         ; cgReturnDataCon con amodes }
  80 \end{code}
  81
  82 Literals are similar to constructors; they return by putting
  83 themselves in an appropriate register and returning to the address on
  84 top of the stack.
  85
  86 \begin{code}
  87 cgExpr (StgLit lit)
  88   = do  { cmm_lit <- cgLit lit
  89         ; performPrimReturn rep (CmmLit cmm_lit) }
  90   where
  91     rep = (typeCgRep) (literalType lit)
  92 \end{code}
  93
  94
  95 %********************************************************
  96 %*                                                      *
  97 %*      PrimOps and foreign calls.
  98 %*                                                      *
  99 %********************************************************
 100
 101 NOTE about "safe" foreign calls: a safe foreign call is never compiled
 102 inline in a case expression.  When we see
 103
 104         case (ccall ...) of { ... }
 105
 106 We generate a proper return address for the alternatives and push the
 107 stack frame before doing the call, so that in the event that the call
 108 re-enters the RTS the stack is in a sane state.
 109
 110 \begin{code}
 111 cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
 112     {-
 113         First, copy the args into temporaries.  We're going to push
 114         a return address right before doing the call, so the args
 115         must be out of the way.
 116     -}
 117     reps_n_amodes <- getArgAmodes stg_args
 118     let
 119         -- Get the *non-void* args, and jiggle them with shimForeignCall
 120         arg_exprs = [ shimForeignCallArg stg_arg expr
 121                     | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
 122                       nonVoidArg rep]
 123
 124     arg_tmps <- mapM assignTemp arg_exprs
 125     let arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args)
 126     {-
 127         Now, allocate some result regs.
 128     -}
 129     (res_reps,res_regs,res_hints)  <- newUnboxedTupleRegs res_ty
 130     ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $
 131         emitForeignCall (zip res_regs res_hints) fcall
 132            arg_hints emptyVarSet{-no live vars-}
 133
 134 -- tagToEnum# is special: we need to pull the constructor out of the table,
 135 -- and perform an appropriate return.
 136
 137 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 138   = ASSERT(isEnumerationTyCon tycon)
 139     do  { (_,amode) <- getArgAmode arg
 140         ; amode' <- assignTemp amode    -- We're going to use it twice,
 141                                         -- so save in a temp if non-trivial
 142         ; this_pkg <- getThisPackage
 143         ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode'))
 144         ; performReturn emitReturnInstr }
 145    where
 146           -- If you're reading this code in the attempt to figure
 147           -- out why the compiler panic'ed here, it is probably because
 148           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 149           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 150           -- That won't work.
 151         tycon = tyConAppTyCon res_ty
 152
 153
 154 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 155   | primOpOutOfLine primop
 156         = tailCallPrimOp primop args
 157
 158   | ReturnsPrim VoidRep <- result_info
 159         = do cgPrimOp [] primop args emptyVarSet
 160              performReturn emitReturnInstr
 161
 162   | ReturnsPrim rep <- result_info
 163         = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
 164                         primop args emptyVarSet
 165              performReturn emitReturnInstr
 166
 167   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
 168         = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
 169              cgPrimOp regs primop args emptyVarSet{-no live vars-}
 170              returnUnboxedTuple (zip reps (map CmmReg regs))
 171
 172   | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
 173         -- c.f. cgExpr (...TagToEnumOp...)
 174         = do tag_reg <- newTemp wordRep
 175              this_pkg <- getThisPackage
 176              cgPrimOp [tag_reg] primop args emptyVarSet
 177              stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg)))
 178              performReturn emitReturnInstr
 179   where
 180         result_info = getPrimOpResultInfo primop
 181 \end{code}
 182
 183 %********************************************************
 184 %*                                                      *
 185 %*              Case expressions                        *
 186 %*                                                      *
 187 %********************************************************
 188 Case-expression conversion is complicated enough to have its own
 189 module, @CgCase@.
 190 \begin{code}
 191
 192 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
 193   = cgCase expr live_vars save_vars bndr srt alt_type alts
 194 \end{code}
 195
 196
 197 %********************************************************
 198 %*                                                      *
 199 %*              Let and letrec                          *
 200 %*                                                      *
 201 %********************************************************
 202 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 203
 204 \begin{code}
 205 cgExpr (StgLet (StgNonRec name rhs) expr)
 206   = cgRhs name rhs      `thenFC` \ (name, info) ->
 207     addBindC name info  `thenC`
 208     cgExpr expr
 209
 210 cgExpr (StgLet (StgRec pairs) expr)
 211   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 212                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 213     ) `thenFC` \ new_bindings ->
 214
 215     addBindsC new_bindings `thenC`
 216     cgExpr expr
 217 \end{code}
 218
 219 \begin{code}
 220 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 221   = do  {       -- Figure out what volatile variables to save
 222         ; nukeDeadBindings live_in_whole_let
 223         ; (save_assts, rhs_eob_info, maybe_cc_slot)
 224                 <- saveVolatileVarsAndRegs live_in_rhss
 225
 226         -- Save those variables right now!
 227         ; emitStmts save_assts
 228
 229         -- Produce code for the rhss
 230         -- and add suitable bindings to the environment
 231         ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info
 232                                 maybe_cc_slot bindings
 233
 234         -- Do the body
 235         ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
 236 \end{code}
 237
 238
 239 %********************************************************
 240 %*                                                      *
 241 %*              SCC Expressions                         *
 242 %*                                                      *
 243 %********************************************************
 244
 245 SCC expressions are treated specially. They set the current cost
 246 centre.
 247
 248 \begin{code}
 249 cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
 250 \end{code}
 251
 252 %********************************************************
 253 %*                                                     *
 254 %*             Hpc Tick Boxes                          *
 255 %*                                                     *
 256 %********************************************************
 257
 258 \begin{code}
 259 cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
 260 \end{code}
 261
 262 %********************************************************
 263 %*                                                      *
 264 %*              Non-top-level bindings                  *
 265 %*                                                      *
 266 %********************************************************
 267 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 268
 269 We rely on the support code in @CgCon@ (to do constructors) and
 270 in @CgClosure@ (to do closures).
 271
 272 \begin{code}
 273 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 274         -- the Id is passed along so a binding can be set up
 275
 276 cgRhs name (StgRhsCon maybe_cc con args)
 277   = do  { amodes <- getArgAmodes args
 278         ; idinfo <- buildDynCon name maybe_cc con amodes
 279         ; returnFC (name, idinfo) }
 280
 281 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
 282   = do this_pkg <- getThisPackage
 283        mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body
 284 \end{code}
 285
 286 mkRhsClosure looks for two special forms of the right-hand side:
 287         a) selector thunks.
 288         b) AP thunks
 289
 290 If neither happens, it just calls mkClosureLFInfo.  You might think
 291 that mkClosureLFInfo should do all this, but it seems wrong for the
 292 latter to look at the structure of an expression
 293
 294 Selectors
 295 ~~~~~~~~~
 296 We look at the body of the closure to see if it's a selector---turgid,
 297 but nothing deep.  We are looking for a closure of {\em exactly} the
 298 form:
 299
 300 ...  = [the_fv] \ u [] ->
 301          case the_fv of
 302            con a_1 ... a_n -> a_i
 303
 304
 305 \begin{code}
 306 mkRhsClosure    this_pkg bndr cc bi srt
 307                 [the_fv]                -- Just one free var
 308                 upd_flag                -- Updatable thunk
 309                 []                      -- A thunk
 310                 body@(StgCase (StgApp scrutinee [{-no args-}])
 311                       _ _ _ _   -- ignore uniq, etc.
 312                       (AlgAlt tycon)
 313                       [(DataAlt con, params, use_mask,
 314                             (StgApp selectee [{-no args-}]))])
 315   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 316   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 317   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 318   = -- NOT TRUE: ASSERT(is_single_constructor)
 319     -- The simplifier may have statically determined that the single alternative
 320     -- is the only possible case and eliminated the others, even if there are
 321     -- other constructors in the datatype.  It's still ok to make a selector
 322     -- thunk in this case, because we *know* which constructor the scrutinee
 323     -- will evaluate to.
 324     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 325   where
 326     lf_info               = mkSelectorLFInfo bndr offset_into_int
 327                                  (isUpdatable upd_flag)
 328     (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params)
 329                         -- Just want the layout
 330     maybe_offset          = assocMaybe params_w_offsets selectee
 331     Just the_offset       = maybe_offset
 332     offset_into_int       = the_offset - fixedHdrSize
 333 \end{code}
 334
 335 Ap thunks
 336 ~~~~~~~~~
 337
 338 A more generic AP thunk of the form
 339
 340         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 341
 342 A set of these is compiled statically into the RTS, so we just use
 343 those.  We could extend the idea to thunks where some of the x_i are
 344 global ids (and hence not free variables), but this would entail
 345 generating a larger thunk.  It might be an option for non-optimising
 346 compilation, though.
 347
 348 We only generate an Ap thunk if all the free variables are pointers,
 349 for semi-obvious reasons.
 350
 351 \begin{code}
 352 mkRhsClosure    this_pkg bndr cc bi srt
 353                 fvs
 354                 upd_flag
 355                 []                      -- No args; a thunk
 356                 body@(StgApp fun_id args)
 357
 358   | args `lengthIs` (arity-1)
 359         && all isFollowableArg (map idCgRep fvs)
 360         && isUpdatable upd_flag
 361         && arity <= mAX_SPEC_AP_SIZE
 362
 363                    -- Ha! an Ap thunk
 364         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 365
 366    where
 367         lf_info = mkApLFInfo bndr upd_flag arity
 368         -- the payload has to be in the correct order, hence we can't
 369         -- just use the fvs.
 370         payload = StgVarArg fun_id : args
 371         arity   = length fvs
 372 \end{code}
 373
 374 The default case
 375 ~~~~~~~~~~~~~~~~
 376 \begin{code}
 377 mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body
 378   = cgRhsClosure bndr cc bi srt fvs upd_flag args body
 379 \end{code}
 380
 381
 382 %********************************************************
 383 %*                                                      *
 384 %*              Let-no-escape bindings
 385 %*                                                      *
 386 %********************************************************
 387 \begin{code}
 388 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 389         (StgNonRec binder rhs)
 390   = do  { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
 391                                             maybe_cc_slot
 392                                             NonRecursive binder rhs
 393         ; addBindC binder info }
 394
 395 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 396   = do  { new_bindings <- fixC (\ new_bindings -> do
 397                 { addBindsC new_bindings
 398                 ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 399                                 rhs_eob_info maybe_cc_slot Recursive b e
 400                           | (b,e) <- pairs ] })
 401
 402         ; addBindsC new_bindings }
 403   where
 404     -- We add the binders to the live-in-rhss set so that we don't
 405     -- delete the bindings for the binder from the environment!
 406     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 407
 408 cgLetNoEscapeRhs
 409     :: StgLiveVars      -- Live in rhss
 410     -> EndOfBlockInfo
 411     -> Maybe VirtualSpOffset
 412     -> RecFlag
 413     -> Id
 414     -> StgRhs
 415     -> FCode (Id, CgIdInfo)
 416
 417 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 418                  (StgRhsClosure cc bi _ upd_flag srt args body)
 419   = -- We could check the update flag, but currently we don't switch it off
 420     -- for let-no-escaped things, so we omit the check too!
 421     -- case upd_flag of
 422     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 423     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 424     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 425         maybe_cc_slot rec args body
 426
 427 -- For a constructor RHS we want to generate a single chunk of code which
 428 -- can be jumped to from many places, which will return the constructor.
 429 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 430 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 431                  (StgRhsCon cc con args)
 432   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
 433                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 434         []      --No args; the binder is data structure, not a function
 435         (StgConApp con args)
 436 \end{code}
 437
 438 Little helper for primitives that return unboxed tuples.
 439
 440 \begin{code}
 441 newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
 442 newUnboxedTupleRegs res_ty =
 443    let
 444         ty_args = tyConAppArgs (repType res_ty)
 445         (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
 446                                                     let rep = typeCgRep ty,
 447                                                     nonVoidArg rep ]
 448    in do
 449    regs <- mapM (newTemp . argMachRep) reps
 450    return (reps,regs,hints)
 451 \end{code}