compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.62 2005/06/21 10:44:41 simonmar 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         ; hmods <- getHomeModules
 156         ; stmtC (CmmAssign nodeReg (tagToClosure hmods tycon amode'))
 157         ; performReturn (emitAlgReturnCode tycon amode') }
 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 emitDirectReturnInstr
 174
 175   | ReturnsPrim rep <- result_info
 176         = do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
 177                         primop args emptyVarSet
 178              performReturn emitDirectReturnInstr
 179
 180   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
 181         = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
 182              cgPrimOp regs primop args emptyVarSet{-no live vars-}
 183              returnUnboxedTuple (zip reps (map CmmReg regs))
 184
 185   | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
 186         -- c.f. cgExpr (...TagToEnumOp...)
 187         = do tag_reg <- newTemp wordRep
 188              hmods <- getHomeModules
 189              cgPrimOp [tag_reg] primop args emptyVarSet
 190              stmtC (CmmAssign nodeReg (tagToClosure hmods tycon (CmmReg tag_reg)))
 191              performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
 192   where
 193         result_info = getPrimOpResultInfo primop
 194 \end{code}
 195
 196 %********************************************************
 197 %*                                                      *
 198 %*              Case expressions                        *
 199 %*                                                      *
 200 %********************************************************
 201 Case-expression conversion is complicated enough to have its own
 202 module, @CgCase@.
 203 \begin{code}
 204
 205 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
 206   = cgCase expr live_vars save_vars bndr srt alt_type alts
 207 \end{code}
 208
 209
 210 %********************************************************
 211 %*                                                      *
 212 %*              Let and letrec                          *
 213 %*                                                      *
 214 %********************************************************
 215 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 216
 217 \begin{code}
 218 cgExpr (StgLet (StgNonRec name rhs) expr)
 219   = cgRhs name rhs      `thenFC` \ (name, info) ->
 220     addBindC name info  `thenC`
 221     cgExpr expr
 222
 223 cgExpr (StgLet (StgRec pairs) expr)
 224   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 225                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 226     ) `thenFC` \ new_bindings ->
 227
 228     addBindsC new_bindings `thenC`
 229     cgExpr expr
 230 \end{code}
 231
 232 \begin{code}
 233 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 234   = do  {       -- Figure out what volatile variables to save
 235         ; nukeDeadBindings live_in_whole_let
 236         ; (save_assts, rhs_eob_info, maybe_cc_slot)
 237                 <- saveVolatileVarsAndRegs live_in_rhss
 238
 239         -- Save those variables right now!
 240         ; emitStmts save_assts
 241
 242         -- Produce code for the rhss
 243         -- and add suitable bindings to the environment
 244         ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info
 245                                 maybe_cc_slot bindings
 246
 247         -- Do the body
 248         ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
 249 \end{code}
 250
 251
 252 %********************************************************
 253 %*                                                      *
 254 %*              SCC Expressions                         *
 255 %*                                                      *
 256 %********************************************************
 257
 258 SCC expressions are treated specially. They set the current cost
 259 centre.
 260
 261 \begin{code}
 262 cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
 263 \end{code}
 264
 265 %********************************************************
 266 %*                                                      *
 267 %*              Non-top-level bindings                  *
 268 %*                                                      *
 269 %********************************************************
 270 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 271
 272 We rely on the support code in @CgCon@ (to do constructors) and
 273 in @CgClosure@ (to do closures).
 274
 275 \begin{code}
 276 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 277         -- the Id is passed along so a binding can be set up
 278
 279 cgRhs name (StgRhsCon maybe_cc con args)
 280   = do  { amodes <- getArgAmodes args
 281         ; idinfo <- buildDynCon name maybe_cc con amodes
 282         ; returnFC (name, idinfo) }
 283
 284 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
 285   = do hmods <- getHomeModules
 286        mkRhsClosure hmods name cc bi srt fvs upd_flag args body
 287 \end{code}
 288
 289 mkRhsClosure looks for two special forms of the right-hand side:
 290         a) selector thunks.
 291         b) AP thunks
 292
 293 If neither happens, it just calls mkClosureLFInfo.  You might think
 294 that mkClosureLFInfo should do all this, but it seems wrong for the
 295 latter to look at the structure of an expression
 296
 297 Selectors
 298 ~~~~~~~~~
 299 We look at the body of the closure to see if it's a selector---turgid,
 300 but nothing deep.  We are looking for a closure of {\em exactly} the
 301 form:
 302
 303 ...  = [the_fv] \ u [] ->
 304          case the_fv of
 305            con a_1 ... a_n -> a_i
 306
 307
 308 \begin{code}
 309 mkRhsClosure    hmods bndr cc bi srt
 310                 [the_fv]                -- Just one free var
 311                 upd_flag                -- Updatable thunk
 312                 []                      -- A thunk
 313                 body@(StgCase (StgApp scrutinee [{-no args-}])
 314                       _ _ _ _   -- ignore uniq, etc.
 315                       (AlgAlt tycon)
 316                       [(DataAlt con, params, use_mask,
 317                             (StgApp selectee [{-no args-}]))])
 318   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 319   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 320   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 321   = -- NOT TRUE: ASSERT(is_single_constructor)
 322     -- The simplifier may have statically determined that the single alternative
 323     -- is the only possible case and eliminated the others, even if there are
 324     -- other constructors in the datatype.  It's still ok to make a selector
 325     -- thunk in this case, because we *know* which constructor the scrutinee
 326     -- will evaluate to.
 327     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 328   where
 329     lf_info               = mkSelectorLFInfo bndr offset_into_int
 330                                  (isUpdatable upd_flag)
 331     (_, params_w_offsets) = layOutDynConstr hmods con (addIdReps params)
 332                         -- Just want the layout
 333     maybe_offset          = assocMaybe params_w_offsets selectee
 334     Just the_offset       = maybe_offset
 335     offset_into_int       = the_offset - fixedHdrSize
 336 \end{code}
 337
 338 Ap thunks
 339 ~~~~~~~~~
 340
 341 A more generic AP thunk of the form
 342
 343         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 344
 345 A set of these is compiled statically into the RTS, so we just use
 346 those.  We could extend the idea to thunks where some of the x_i are
 347 global ids (and hence not free variables), but this would entail
 348 generating a larger thunk.  It might be an option for non-optimising
 349 compilation, though.
 350
 351 We only generate an Ap thunk if all the free variables are pointers,
 352 for semi-obvious reasons.
 353
 354 \begin{code}
 355 mkRhsClosure    hmods bndr cc bi srt
 356                 fvs
 357                 upd_flag
 358                 []                      -- No args; a thunk
 359                 body@(StgApp fun_id args)
 360
 361   | args `lengthIs` (arity-1)
 362         && all isFollowableArg (map idCgRep fvs)
 363         && isUpdatable upd_flag
 364         && arity <= mAX_SPEC_AP_SIZE
 365
 366                    -- Ha! an Ap thunk
 367         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 368
 369    where
 370         lf_info = mkApLFInfo bndr upd_flag arity
 371         -- the payload has to be in the correct order, hence we can't
 372         -- just use the fvs.
 373         payload = StgVarArg fun_id : args
 374         arity   = length fvs
 375 \end{code}
 376
 377 The default case
 378 ~~~~~~~~~~~~~~~~
 379 \begin{code}
 380 mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body
 381   = cgRhsClosure bndr cc bi srt fvs upd_flag args body
 382 \end{code}
 383
 384
 385 %********************************************************
 386 %*                                                      *
 387 %*              Let-no-escape bindings
 388 %*                                                      *
 389 %********************************************************
 390 \begin{code}
 391 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 392         (StgNonRec binder rhs)
 393   = do  { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
 394                                             maybe_cc_slot
 395                                             NonRecursive binder rhs
 396         ; addBindC binder info }
 397
 398 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 399   = do  { new_bindings <- fixC (\ new_bindings -> do
 400                 { addBindsC new_bindings
 401                 ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 402                                 rhs_eob_info maybe_cc_slot Recursive b e
 403                           | (b,e) <- pairs ] })
 404
 405         ; addBindsC new_bindings }
 406   where
 407     -- We add the binders to the live-in-rhss set so that we don't
 408     -- delete the bindings for the binder from the environment!
 409     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 410
 411 cgLetNoEscapeRhs
 412     :: StgLiveVars      -- Live in rhss
 413     -> EndOfBlockInfo
 414     -> Maybe VirtualSpOffset
 415     -> RecFlag
 416     -> Id
 417     -> StgRhs
 418     -> FCode (Id, CgIdInfo)
 419
 420 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 421                  (StgRhsClosure cc bi _ upd_flag srt args body)
 422   = -- We could check the update flag, but currently we don't switch it off
 423     -- for let-no-escaped things, so we omit the check too!
 424     -- case upd_flag of
 425     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 426     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 427     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 428         maybe_cc_slot rec args body
 429
 430 -- For a constructor RHS we want to generate a single chunk of code which
 431 -- can be jumped to from many places, which will return the constructor.
 432 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 433 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 434                  (StgRhsCon cc con args)
 435   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
 436                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 437         []      --No args; the binder is data structure, not a function
 438         (StgConApp con args)
 439 \end{code}
 440
 441 Little helper for primitives that return unboxed tuples.
 442
 443 \begin{code}
 444 newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
 445 newUnboxedTupleRegs res_ty =
 446    let
 447         ty_args = tyConAppArgs (repType res_ty)
 448         (reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
 449                                                     let rep = typeCgRep ty,
 450                                                     nonVoidArg rep ]
 451    in do
 452    regs <- mapM (newTemp . argMachRep) reps
 453    return (reps,regs,hints)
 454 \end{code}