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