ghc/compiler/codeGen/CgExpr.lhs

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