ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.46 2001/10/25 02:13:11 sof 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 import AbsCSyn
  21 import AbsCUtils        ( mkAbstractCs )
  22 import CLabel           ( mkClosureTblLabel )
  23
  24 import SMRep            ( fixedHdrSize )
  25 import CgBindery        ( getArgAmodes, getArgAmode, CgIdInfo,
  26                           nukeDeadBindings, addBindC, addBindsC )
  27 import CgCase           ( cgCase, saveVolatileVarsAndRegs,
  28                           restoreCurrentCostCentre )
  29 import CgClosure        ( cgRhsClosure, cgStdRhsClosure )
  30 import CgCon            ( buildDynCon, cgReturnDataCon )
  31 import CgLetNoEscape    ( cgLetNoEscapeClosure )
  32 import CgRetConv        ( dataReturnConvPrim )
  33 import CgTailCall       ( cgTailCall, performReturn, performPrimReturn,
  34                           mkDynamicAlgReturnCode, mkPrimReturnCode,
  35                           tailCallPrimOp, returnUnboxedTuple
  36                         )
  37 import ClosureInfo      ( mkClosureLFInfo, mkSelectorLFInfo,
  38                           mkApLFInfo, layOutDynConstr )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, idType, Id )
  41 import VarSet
  42 import PrimOp           ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
  43 import PrimRep          ( PrimRep(..), isFollowableRep )
  44 import TyCon            ( maybeTyConSingleCon,
  45                           isUnboxedTupleTyCon, isEnumerationTyCon )
  46 import Type             ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
  47 import Maybes           ( maybeToBool )
  48 import ListSetOps       ( assocMaybe )
  49 import Unique           ( mkBuiltinUnique )
  50 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  51 import Util             ( lengthIs )
  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   = getArgAmodes args `thenFC` \ amodes ->
  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   = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
  97 \end{code}
  98
  99
 100 %********************************************************
 101 %*                                                      *
 102 %*              STG PrimApps  (unboxed primitive ops)   *
 103 %*                                                      *
 104 %********************************************************
 105
 106 Here is where we insert real live machine instructions.
 107
 108 NOTE about _ccall_GC_:
 109
 110 A _ccall_GC_ is treated as an out-of-line primop (returns True
 111 for primOpOutOfLine) so that when we see the call in case context
 112         case (ccall ...) of { ... }
 113 we get a proper stack frame on the stack when we perform it.  When we
 114 get in a tail-call position, however, we need to actually perform the
 115 call, so we treat it as an inline primop.
 116
 117 \begin{code}
 118 cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
 119   = primRetUnboxedTuple op args res_ty
 120
 121 -- tagToEnum# is special: we need to pull the constructor out of the table,
 122 -- and perform an appropriate return.
 123
 124 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 125   = ASSERT(isEnumerationTyCon tycon)
 126     getArgAmode arg `thenFC` \amode ->
 127         -- save the tag in a temporary in case amode overlaps
 128         -- with node.
 129     absC (CAssign dyn_tag amode)        `thenC`
 130     performReturn (
 131                 CAssign (CReg node)
 132                         (CVal (CIndex
 133                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 134                           dyn_tag PtrRep) PtrRep))
 135             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 136    where
 137         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 138           --
 139           -- if you're reading this code in the attempt to figure
 140           -- out why the compiler panic'ed here, it is probably because
 141           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 142           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 143           --
 144           -- That won't work.
 145           --
 146         tycon = tyConAppTyCon res_ty
 147
 148
 149 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 150   | primOpOutOfLine primop
 151   = tailCallPrimOp primop args
 152
 153   | otherwise
 154   = ASSERT(primop /= SeqOp) -- can't handle SeqOp
 155
 156     getArgAmodes args   `thenFC` \ arg_amodes ->
 157
 158     case (getPrimOpResultInfo primop) of
 159
 160         ReturnsPrim kind ->
 161             let result_amode = CReg (dataReturnConvPrim kind) in
 162             performReturn
 163               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 164               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 165
 166         -- otherwise, must be returning an enumerated type (eg. Bool).
 167         -- we've only got the tag in R2, so we have to load the constructor
 168         -- itself into R1.
 169
 170         ReturnsAlg tycon
 171             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 172
 173             | isEnumerationTyCon  tycon ->
 174                 performReturn
 175                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 176                           (\ sequel ->
 177                           absC (CAssign (CReg node) closure_lbl) `thenC`
 178                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 179
 180             where
 181                -- Pull a unique out of thin air to put the tag in.
 182                -- It shouldn't matter if this overlaps with anything - we're
 183                -- about to return anyway.
 184                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 185
 186                closure_lbl = CVal (CIndex
 187                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 188                                dyn_tag PtrRep) PtrRep
 189
 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 alts)
 202   = cgCase expr live_vars save_vars bndr srt 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 srt name rhs) expr)
 215   = cgRhs srt name rhs  `thenFC` \ (name, info) ->
 216     addBindC name info  `thenC`
 217     cgExpr expr
 218
 219 cgExpr (StgLet (StgRec srt pairs) expr)
 220   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 221                             listFCs [ cgRhs srt 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   =     -- Figure out what volatile variables to save
 231     nukeDeadBindings live_in_whole_let  `thenC`
 232     saveVolatileVarsAndRegs live_in_rhss
 233             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 234     -- ToDo: cost centre???
 235     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 236
 237         -- Save those variables right now!
 238     absC save_assts                             `thenC`
 239
 240         -- Produce code for the rhss
 241         -- and add suitable bindings to the environment
 242     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 243
 244         -- Do the body
 245     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 246 \end{code}
 247
 248
 249 %********************************************************
 250 %*                                                      *
 251 %*              SCC Expressions                         *
 252 %*                                                      *
 253 %********************************************************
 254
 255 SCC expressions are treated specially. They set the current cost
 256 centre.
 257 \begin{code}
 258 cgExpr (StgSCC cc expr)
 259   = ASSERT(sccAbleCostCentre cc)
 260     costCentresC
 261         SLIT("SET_CCC")
 262         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 263     `thenC`
 264     cgExpr expr
 265 \end{code}
 266
 267 ToDo: counting of dict sccs ...
 268
 269 %********************************************************
 270 %*                                                      *
 271 %*              Non-top-level bindings                  *
 272 %*                                                      *
 273 %********************************************************
 274 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 275
 276 We rely on the support code in @CgCon@ (to do constructors) and
 277 in @CgClosure@ (to do closures).
 278
 279 \begin{code}
 280 cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
 281         -- the Id is passed along so a binding can be set up
 282
 283 cgRhs srt name (StgRhsCon maybe_cc con args)
 284   = getArgAmodes args                           `thenFC` \ amodes ->
 285     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 286     returnFC (name, idinfo)
 287
 288 cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
 289   = mkRhsClosure name cc bi srt fvs upd_flag args body
 290 \end{code}
 291
 292 mkRhsClosure looks for two special forms of the right-hand side:
 293         a) selector thunks.
 294         b) AP thunks
 295
 296 If neither happens, it just calls mkClosureLFInfo.  You might think
 297 that mkClosureLFInfo should do all this, but it seems wrong for the
 298 latter to look at the structure of an expression
 299
 300 Selectors
 301 ~~~~~~~~~
 302 We look at the body of the closure to see if it's a selector---turgid,
 303 but nothing deep.  We are looking for a closure of {\em exactly} the
 304 form:
 305
 306 ...  = [the_fv] \ u [] ->
 307          case the_fv of
 308            con a_1 ... a_n -> a_i
 309
 310
 311 \begin{code}
 312 mkRhsClosure    bndr cc bi srt
 313                 [the_fv]                -- Just one free var
 314                 upd_flag                -- Updatable thunk
 315                 []                      -- A thunk
 316                 body@(StgCase (StgApp scrutinee [{-no args-}])
 317                       _ _ _ _   -- ignore uniq, etc.
 318                       (StgAlgAlts (Just tycon)
 319                          [(con, params, use_mask,
 320                             (StgApp selectee [{-no args-}]))]
 321                          StgNoDefault))
 322   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 323   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 324   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 325   = -- NOT TRUE: ASSERT(is_single_constructor)
 326     -- The simplifier may have statically determined that the single alternative
 327     -- is the only possible case and eliminated the others, even if there are
 328     -- other constructors in the datatype.  It's still ok to make a selector
 329     -- thunk in this case, because we *know* which constructor the scrutinee
 330     -- will evaluate to.
 331     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 332   where
 333     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 334                                                 (isUpdatable upd_flag)
 335     (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
 336                                 -- Just want the layout
 337     maybe_offset          = assocMaybe params_w_offsets selectee
 338     Just the_offset       = maybe_offset
 339     offset_into_int       = the_offset - fixedHdrSize
 340     bogus_name            = panic "mkRhsClosure"
 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 srt
 361                 fvs
 362                 upd_flag
 363                 []                      -- No args; a thunk
 364                 body@(StgApp fun_id args)
 365
 366   | args `lengthIs` (arity-1)
 367         && all isFollowableRep (map idPrimRep 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 (idType 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 srt fvs upd_flag args body
 386   = cgRhsClosure bndr cc bi srt fvs args body lf_info
 387   where
 388     lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 389 \end{code}
 390
 391
 392 %********************************************************
 393 %*                                                      *
 394 %*              Let-no-escape bindings
 395 %*                                                      *
 396 %********************************************************
 397 \begin{code}
 398 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 399         (StgNonRec srt binder rhs)
 400   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 401                         NonRecursive srt binder rhs
 402                                 `thenFC` \ (binder, info) ->
 403     addBindC binder info
 404
 405 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 406         (StgRec srt pairs)
 407   = fixC (\ new_bindings ->
 408                 addBindsC new_bindings  `thenC`
 409                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 410                                 rhs_eob_info maybe_cc_slot Recursive srt b e
 411                         | (b,e) <- pairs ]
 412     ) `thenFC` \ new_bindings ->
 413
 414     addBindsC new_bindings
 415   where
 416     -- We add the binders to the live-in-rhss set so that we don't
 417     -- delete the bindings for the binder from the environment!
 418     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 419
 420 cgLetNoEscapeRhs
 421     :: StgLiveVars      -- Live in rhss
 422     -> EndOfBlockInfo
 423     -> Maybe VirtualSpOffset
 424     -> RecFlag
 425     -> SRT
 426     -> Id
 427     -> StgRhs
 428     -> FCode (Id, CgIdInfo)
 429
 430 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 431                  (StgRhsClosure cc bi _ upd_flag args body)
 432   = -- We could check the update flag, but currently we don't switch it off
 433     -- for let-no-escaped things, so we omit the check too!
 434     -- case upd_flag of
 435     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 436     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 437     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 438         maybe_cc_slot rec args body
 439
 440 -- For a constructor RHS we want to generate a single chunk of code which
 441 -- can be jumped to from many places, which will return the constructor.
 442 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 443 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 444                  (StgRhsCon cc con args)
 445   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
 446                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 447         []      --No args; the binder is data structure, not a function
 448         (StgConApp con args)
 449 \end{code}
 450
 451 Little helper for primitives that return unboxed tuples.
 452
 453
 454 \begin{code}
 455 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 456 primRetUnboxedTuple op args res_ty
 457   = getArgAmodes args       `thenFC` \ arg_amodes ->
 458     {-
 459       put all the arguments in temporaries so they don't get stomped when
 460       we push the return address.
 461     -}
 462     let
 463       n_args              = length args
 464       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 465       arg_reps            = map getArgPrimRep args
 466       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 467     in
 468     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 469     {-
 470       allocate some temporaries for the return values.
 471     -}
 472     let
 473       ty_args     = tyConAppArgs (repType res_ty)
 474       prim_reps   = map typePrimRep ty_args
 475       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 476       temp_amodes = zipWith CTemp temp_uniqs prim_reps
 477     in
 478     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 479 \end{code}