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