ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.24 1999/05/07 13:44:00 simonm 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, nukeDeadBindings)
  26 import CgCase           ( cgCase, saveVolatileVarsAndRegs,
  27                           restoreCurrentCostCentre, freeCostCentreSlot,
  28                           splitTyConAppThroughNewTypes )
  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, layOutDynCon )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, idType, Id )
  41 import VarSet
  42 import DataCon          ( DataCon, dataConTyCon )
  43 import Const            ( Con(..) )
  44 import IdInfo           ( ArityInfo(..) )
  45 import PrimOp           ( primOpOutOfLine,
  46                           getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
  47                         )
  48 import PrimRep          ( getPrimRepSize, PrimRep(..), isFollowableRep )
  49 import TyCon            ( maybeTyConSingleCon,
  50                           isUnboxedTupleTyCon, isEnumerationTyCon )
  51 import Type             ( Type, typePrimRep, splitTyConApp_maybe )
  52 import Maybes           ( assocMaybe, maybeToBool )
  53 import Unique           ( mkBuiltinUnique )
  54 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  55 import Outputable
  56 \end{code}
  57
  58 This module provides the support code for @StgToAbstractC@ to deal
  59 with STG {\em expressions}.  See also @CgClosure@, which deals
  60 with closures, and @CgCon@, which deals with constructors.
  61
  62 \begin{code}
  63 cgExpr  :: StgExpr              -- input
  64         -> Code                 -- output
  65 \end{code}
  66
  67 %********************************************************
  68 %*                                                      *
  69 %*              Tail calls                              *
  70 %*                                                      *
  71 %********************************************************
  72
  73 ``Applications'' mean {\em tail calls}, a service provided by module
  74 @CgTailCall@.  This includes literals, which show up as
  75 @(STGApp (StgLitArg 42) [])@.
  76
  77 \begin{code}
  78 cgExpr (StgApp fun args) = cgTailCall fun args
  79 \end{code}
  80
  81 %********************************************************
  82 %*                                                      *
  83 %*              STG ConApps  (for inline versions)      *
  84 %*                                                      *
  85 %********************************************************
  86
  87 \begin{code}
  88 cgExpr (StgCon (DataCon con) args res_ty)
  89   = getArgAmodes args `thenFC` \ amodes ->
  90     cgReturnDataCon con amodes (all zero_size args)
  91   where
  92     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
  93 \end{code}
  94
  95 Literals are similar to constructors; they return by putting
  96 themselves in an appropriate register and returning to the address on
  97 top of the stack.
  98
  99 \begin{code}
 100 cgExpr (StgCon (Literal lit) args res_ty)
 101   = ASSERT( null args )
 102     performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
 103 \end{code}
 104
 105
 106 %********************************************************
 107 %*                                                      *
 108 %*              STG PrimApps  (unboxed primitive ops)   *
 109 %*                                                      *
 110 %********************************************************
 111
 112 Here is where we insert real live machine instructions.
 113
 114 NOTE about _ccall_GC_:
 115
 116 A _ccall_GC_ is treated as an out-of-line primop for the case
 117 expression code, because we want a proper stack frame on the stack
 118 when we perform it.  When we get here, however, we need to actually
 119 perform the call, so we treat it as an inline primop.
 120
 121 \begin{code}
 122 cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
 123   = primRetUnboxedTuple op args res_ty
 124
 125 -- tagToEnum# is special: we need to pull the constructor out of the table,
 126 -- and perform an appropriate return.
 127
 128 cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
 129   = ASSERT(isEnumerationTyCon tycon)
 130     getArgAmode arg `thenFC` \amode ->
 131         -- save the tag in a temporary in case amode overlaps
 132         -- with node.
 133     absC (CAssign dyn_tag amode)        `thenC`
 134     performReturn (
 135                 CAssign (CReg node)
 136                         (CTableEntry
 137                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 138                           dyn_tag PtrRep))
 139             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 140    where
 141         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 142         (Just (tycon,_)) = splitTyConApp_maybe res_ty
 143
 144
 145 cgExpr x@(StgCon (PrimOp op) args res_ty)
 146   | primOpOutOfLine op = tailCallPrimOp op args
 147   | otherwise
 148   = ASSERT(op /= SeqOp) -- can't handle SeqOp
 149
 150     getArgAmodes args   `thenFC` \ arg_amodes ->
 151
 152     case (getPrimOpResultInfo op) of
 153
 154         ReturnsPrim kind ->
 155             let result_amode = CReg (dataReturnConvPrim kind) in
 156             performReturn
 157               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 158               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 159
 160         -- otherwise, must be returning an enumerated type (eg. Bool).
 161         -- we've only got the tag in R2, so we have to load the constructor
 162         -- itself into R1.
 163
 164         ReturnsAlg tycon
 165             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 166
 167             | isEnumerationTyCon  tycon ->
 168                 performReturn
 169                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 170                           (\ sequel ->
 171                           absC (CAssign (CReg node) closure_lbl) `thenC`
 172                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 173
 174             where
 175                -- Pull a unique out of thin air to put the tag in.
 176                -- It shouldn't matter if this overlaps with anything - we're
 177                -- about to return anyway.
 178                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 179
 180                closure_lbl = CTableEntry
 181                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 182                                dyn_tag PtrRep
 183
 184 \end{code}
 185
 186 %********************************************************
 187 %*                                                      *
 188 %*              Case expressions                        *
 189 %*                                                      *
 190 %********************************************************
 191 Case-expression conversion is complicated enough to have its own
 192 module, @CgCase@.
 193 \begin{code}
 194
 195 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 196   = cgCase expr live_vars save_vars bndr srt alts
 197 \end{code}
 198
 199
 200 %********************************************************
 201 %*                                                      *
 202 %*              Let and letrec                          *
 203 %*                                                      *
 204 %********************************************************
 205 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 206
 207 \begin{code}
 208 cgExpr (StgLet (StgNonRec name rhs) expr)
 209   = cgRhs name rhs      `thenFC` \ (name, info) ->
 210     addBindC name info  `thenC`
 211     cgExpr expr
 212
 213 cgExpr (StgLet (StgRec pairs) expr)
 214   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 215                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 216     ) `thenFC` \ new_bindings ->
 217
 218     addBindsC new_bindings `thenC`
 219     cgExpr expr
 220 \end{code}
 221
 222 \begin{code}
 223 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 224   =     -- Figure out what volatile variables to save
 225     nukeDeadBindings live_in_whole_let  `thenC`
 226     saveVolatileVarsAndRegs live_in_rhss
 227             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 228     -- ToDo: cost centre???
 229     freeCostCentreSlot maybe_cc_slot       `thenC`
 230     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 231
 232         -- Save those variables right now!
 233     absC save_assts                             `thenC`
 234
 235         -- Produce code for the rhss
 236         -- and add suitable bindings to the environment
 237     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 238
 239         -- Do the body
 240     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 241 \end{code}
 242
 243
 244 %********************************************************
 245 %*                                                      *
 246 %*              SCC Expressions                         *
 247 %*                                                      *
 248 %********************************************************
 249
 250 SCC expressions are treated specially. They set the current cost
 251 centre.
 252 \begin{code}
 253 cgExpr (StgSCC cc expr)
 254   = ASSERT(sccAbleCostCentre cc)
 255     costCentresC
 256         SLIT("SET_CCC")
 257         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 258     `thenC`
 259     cgExpr expr
 260 \end{code}
 261
 262 ToDo: counting of dict sccs ...
 263
 264 %********************************************************
 265 %*                                                      *
 266 %*              Non-top-level bindings                  *
 267 %*                                                      *
 268 %********************************************************
 269 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 270
 271 We rely on the support code in @CgCon@ (to do constructors) and
 272 in @CgClosure@ (to do closures).
 273
 274 \begin{code}
 275 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 276         -- the Id is passed along so a binding can be set up
 277
 278 cgRhs name (StgRhsCon maybe_cc con args)
 279   = getArgAmodes args           `thenFC` \ amodes ->
 280     buildDynCon name maybe_cc con amodes (all zero_size args)
 281                                 `thenFC` \ idinfo ->
 282     returnFC (name, idinfo)
 283   where
 284     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 285
 286 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
 287   = mkRhsClosure name cc bi srt fvs upd_flag args body
 288 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) 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 case_ty
 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   = ASSERT(is_single_constructor)
 326     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 327   where
 328     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 329                                 (isUpdatable upd_flag)
 330     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 331     maybe_offset          = assocMaybe params_w_offsets selectee
 332     Just the_offset       = maybe_offset
 333     offset_into_int       = the_offset - fixedHdrSize
 334     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 335     tycon                 = dataConTyCon con
 336 \end{code}
 337
 338
 339 Ap thunks
 340 ~~~~~~~~~
 341
 342 A more generic AP thunk of the form
 343
 344         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 345
 346 A set of these is compiled statically into the RTS, so we just use
 347 those.  We could extend the idea to thunks where some of the x_i are
 348 global ids (and hence not free variables), but this would entail
 349 generating a larger thunk.  It might be an option for non-optimising
 350 compilation, though.
 351
 352 We only generate an Ap thunk if all the free variables are pointers,
 353 for semi-obvious reasons.
 354
 355 \begin{code}
 356 mkRhsClosure    bndr cc bi srt
 357                 fvs
 358                 upd_flag
 359                 []                      -- No args; a thunk
 360                 body@(StgApp fun_id args)
 361
 362   | length args + 1 == arity
 363         && all isFollowableRep (map idPrimRep fvs)
 364         && isUpdatable upd_flag
 365         && arity <= mAX_SPEC_AP_SIZE
 366
 367                    -- Ha! an Ap thunk
 368         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 369
 370    where
 371         lf_info = mkApLFInfo (idType bndr) upd_flag arity
 372         -- the payload has to be in the correct order, hence we can't
 373         -- just use the fvs.
 374         payload    = StgVarArg fun_id : args
 375         arity      = length fvs
 376 \end{code}
 377
 378 The default case
 379 ~~~~~~~~~~~~~~~~
 380 \begin{code}
 381 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 382   = getSRTLabel         `thenFC` \ srt_label ->
 383     let lf_info =
 384           mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
 385     in
 386     cgRhsClosure bndr cc bi fvs args body lf_info
 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 (StgNonRec binder rhs)
 397   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 398                         NonRecursive binder rhs
 399                                 `thenFC` \ (binder, info) ->
 400     addBindC binder info
 401
 402 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 403   = fixC (\ new_bindings ->
 404                 addBindsC new_bindings  `thenC`
 405                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 406                                 rhs_eob_info maybe_cc_slot Recursive b e
 407                         | (b,e) <- pairs ]
 408     ) `thenFC` \ new_bindings ->
 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 srt _ upd_flag 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     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
 433
 434 -- For a constructor RHS we want to generate a single chunk of code which
 435 -- can be jumped to from many places, which will return the constructor.
 436 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 437 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 438                  (StgRhsCon cc con args)
 439   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 440         []      --No args; the binder is data structure, not a function
 441         (StgCon (DataCon con) args (idType binder))
 442 \end{code}
 443
 444 Little helper for primitives that return unboxed tuples.
 445
 446
 447 \begin{code}
 448 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
 449 primRetUnboxedTuple op args res_ty
 450   = getArgAmodes args       `thenFC` \ arg_amodes ->
 451     {-
 452       put all the arguments in temporaries so they don't get stomped when
 453       we push the return address.
 454     -}
 455     let
 456       n_args              = length args
 457       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 458       arg_reps            = map getArgPrimRep args
 459       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 460     in
 461     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 462     {-
 463       allocate some temporaries for the return values.
 464     -}
 465     let
 466       (tc,ty_args)      = case splitTyConAppThroughNewTypes res_ty of
 467                             Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 468                             Just pr -> pr
 469       prim_reps          = map typePrimRep ty_args
 470       temp_uniqs         = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 471       temp_amodes        = zipWith CTemp temp_uniqs prim_reps
 472     in
 473     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 474
 475 \end{code}