ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.23 1999/04/23 13:53:29 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   | isEnumerationTyCon tycon =
 130         getArgAmode arg `thenFC` \amode ->
 131         performReturn (CAssign (CReg node)
 132                         (CTableEntry
 133                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 134                           amode PtrRep))
 135                   (\ sequel -> mkDynamicAlgReturnCode tycon amode sequel)
 136
 137   | otherwise = panic "cgExpr: tagToEnum# of non-enumerated type"
 138
 139    where
 140         (Just (tycon,_)) = splitTyConApp_maybe res_ty
 141
 142
 143 cgExpr x@(StgCon (PrimOp op) args res_ty)
 144   | primOpOutOfLine op = tailCallPrimOp op args
 145   | otherwise
 146   = ASSERT(op /= SeqOp) -- can't handle SeqOp
 147
 148     getArgAmodes args   `thenFC` \ arg_amodes ->
 149
 150     case (getPrimOpResultInfo op) of
 151
 152         ReturnsPrim kind ->
 153             let result_amode = CReg (dataReturnConvPrim kind) in
 154             performReturn
 155               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 156               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 157
 158         -- otherwise, must be returning an enumerated type (eg. Bool).
 159         -- we've only got the tag in R2, so we have to load the constructor
 160         -- itself into R1.
 161
 162         ReturnsAlg tycon
 163             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 164
 165             | isEnumerationTyCon  tycon ->
 166                 performReturn
 167                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 168                           (\ sequel ->
 169                           absC (CAssign (CReg node) closure_lbl) `thenC`
 170                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 171
 172             where
 173                -- Pull a unique out of thin air to put the tag in.
 174                -- It shouldn't matter if this overlaps with anything - we're
 175                -- about to return anyway.
 176                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 177
 178                closure_lbl = CTableEntry
 179                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 180                                dyn_tag PtrRep
 181
 182 \end{code}
 183
 184 %********************************************************
 185 %*                                                      *
 186 %*              Case expressions                        *
 187 %*                                                      *
 188 %********************************************************
 189 Case-expression conversion is complicated enough to have its own
 190 module, @CgCase@.
 191 \begin{code}
 192
 193 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 194   = cgCase expr live_vars save_vars bndr srt alts
 195 \end{code}
 196
 197
 198 %********************************************************
 199 %*                                                      *
 200 %*              Let and letrec                          *
 201 %*                                                      *
 202 %********************************************************
 203 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 204
 205 \begin{code}
 206 cgExpr (StgLet (StgNonRec name rhs) expr)
 207   = cgRhs name rhs      `thenFC` \ (name, info) ->
 208     addBindC name info  `thenC`
 209     cgExpr expr
 210
 211 cgExpr (StgLet (StgRec pairs) expr)
 212   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 213                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 214     ) `thenFC` \ new_bindings ->
 215
 216     addBindsC new_bindings `thenC`
 217     cgExpr expr
 218 \end{code}
 219
 220 \begin{code}
 221 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 222   =     -- Figure out what volatile variables to save
 223     nukeDeadBindings live_in_whole_let  `thenC`
 224     saveVolatileVarsAndRegs live_in_rhss
 225             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 226     -- ToDo: cost centre???
 227     freeCostCentreSlot maybe_cc_slot       `thenC`
 228     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 229
 230         -- Save those variables right now!
 231     absC save_assts                             `thenC`
 232
 233         -- Produce code for the rhss
 234         -- and add suitable bindings to the environment
 235     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 236
 237         -- Do the body
 238     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 239 \end{code}
 240
 241
 242 %********************************************************
 243 %*                                                      *
 244 %*              SCC Expressions                         *
 245 %*                                                      *
 246 %********************************************************
 247
 248 SCC expressions are treated specially. They set the current cost
 249 centre.
 250 \begin{code}
 251 cgExpr (StgSCC cc expr)
 252   = ASSERT(sccAbleCostCentre cc)
 253     costCentresC
 254         SLIT("SET_CCC")
 255         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 256     `thenC`
 257     cgExpr expr
 258 \end{code}
 259
 260 ToDo: counting of dict sccs ...
 261
 262 %********************************************************
 263 %*                                                      *
 264 %*              Non-top-level bindings                  *
 265 %*                                                      *
 266 %********************************************************
 267 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 268
 269 We rely on the support code in @CgCon@ (to do constructors) and
 270 in @CgClosure@ (to do closures).
 271
 272 \begin{code}
 273 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 274         -- the Id is passed along so a binding can be set up
 275
 276 cgRhs name (StgRhsCon maybe_cc con args)
 277   = getArgAmodes args           `thenFC` \ amodes ->
 278     buildDynCon name maybe_cc con amodes (all zero_size args)
 279                                 `thenFC` \ idinfo ->
 280     returnFC (name, idinfo)
 281   where
 282     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 283
 284 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
 285   = mkRhsClosure name cc bi srt fvs upd_flag args body
 286 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
 287   = mkRhsClosure name cc bi srt fvs upd_flag args body
 288 \end{code}
 289
 290 mkRhsClosure looks for two special forms of the right-hand side:
 291         a) selector thunks.
 292         b) AP thunks
 293
 294 If neither happens, it just calls mkClosureLFInfo.  You might think
 295 that mkClosureLFInfo should do all this, but it seems wrong for the
 296 latter to look at the structure of an expression
 297
 298 Selectors
 299 ~~~~~~~~~
 300 We look at the body of the closure to see if it's a selector---turgid,
 301 but nothing deep.  We are looking for a closure of {\em exactly} the
 302 form:
 303
 304 ...  = [the_fv] \ u [] ->
 305          case the_fv of
 306            con a_1 ... a_n -> a_i
 307
 308
 309 \begin{code}
 310 mkRhsClosure    bndr cc bi srt
 311                 [the_fv]                -- Just one free var
 312                 upd_flag                -- Updatable thunk
 313                 []                      -- A thunk
 314                 body@(StgCase (StgApp scrutinee [{-no args-}])
 315                       _ _ _ _   -- ignore uniq, etc.
 316                       (StgAlgAlts case_ty
 317                          [(con, params, use_mask,
 318                             (StgApp selectee [{-no args-}]))]
 319                          StgNoDefault))
 320   |  the_fv == scrutinee                        -- Scrutinee is the only free variable
 321   && maybeToBool maybe_offset                   -- Selectee is a component of the tuple
 322   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 323   = ASSERT(is_single_constructor)
 324     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 325   where
 326     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 327                                 (isUpdatable upd_flag)
 328     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 329     maybe_offset          = assocMaybe params_w_offsets selectee
 330     Just the_offset       = maybe_offset
 331     offset_into_int       = the_offset - fixedHdrSize
 332     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 333     tycon                 = dataConTyCon con
 334 \end{code}
 335
 336
 337 Ap thunks
 338 ~~~~~~~~~
 339
 340 A more generic AP thunk of the form
 341
 342         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 343
 344 A set of these is compiled statically into the RTS, so we just use
 345 those.  We could extend the idea to thunks where some of the x_i are
 346 global ids (and hence not free variables), but this would entail
 347 generating a larger thunk.  It might be an option for non-optimising
 348 compilation, though.
 349
 350 We only generate an Ap thunk if all the free variables are pointers,
 351 for semi-obvious reasons.
 352
 353 \begin{code}
 354 mkRhsClosure    bndr cc bi srt
 355                 fvs
 356                 upd_flag
 357                 []                      -- No args; a thunk
 358                 body@(StgApp fun_id args)
 359
 360   | length args + 1 == arity
 361         && all isFollowableRep (map idPrimRep fvs)
 362         && isUpdatable upd_flag
 363         && arity <= mAX_SPEC_AP_SIZE
 364
 365                    -- Ha! an Ap thunk
 366         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 367
 368    where
 369         lf_info = mkApLFInfo (idType bndr) upd_flag arity
 370         -- the payload has to be in the correct order, hence we can't
 371         -- just use the fvs.
 372         payload    = StgVarArg fun_id : args
 373         arity      = length fvs
 374 \end{code}
 375
 376 The default case
 377 ~~~~~~~~~~~~~~~~
 378 \begin{code}
 379 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 380   = getSRTLabel         `thenFC` \ srt_label ->
 381     let lf_info =
 382           mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
 383     in
 384     cgRhsClosure bndr cc bi fvs args body lf_info
 385 \end{code}
 386
 387
 388 %********************************************************
 389 %*                                                      *
 390 %*              Let-no-escape bindings
 391 %*                                                      *
 392 %********************************************************
 393 \begin{code}
 394 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 395   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 396                         NonRecursive binder rhs
 397                                 `thenFC` \ (binder, info) ->
 398     addBindC binder info
 399
 400 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 401   = fixC (\ new_bindings ->
 402                 addBindsC new_bindings  `thenC`
 403                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 404                                 rhs_eob_info maybe_cc_slot Recursive b e
 405                         | (b,e) <- pairs ]
 406     ) `thenFC` \ new_bindings ->
 407
 408     addBindsC new_bindings
 409   where
 410     -- We add the binders to the live-in-rhss set so that we don't
 411     -- delete the bindings for the binder from the environment!
 412     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 413
 414 cgLetNoEscapeRhs
 415     :: StgLiveVars      -- Live in rhss
 416     -> EndOfBlockInfo
 417     -> Maybe VirtualSpOffset
 418     -> RecFlag
 419     -> Id
 420     -> StgRhs
 421     -> FCode (Id, CgIdInfo)
 422
 423 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 424                  (StgRhsClosure cc bi srt _ upd_flag args body)
 425   = -- We could check the update flag, but currently we don't switch it off
 426     -- for let-no-escaped things, so we omit the check too!
 427     -- case upd_flag of
 428     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 429     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 430     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
 431
 432 -- For a constructor RHS we want to generate a single chunk of code which
 433 -- can be jumped to from many places, which will return the constructor.
 434 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 435 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 436                  (StgRhsCon cc con args)
 437   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 438         []      --No args; the binder is data structure, not a function
 439         (StgCon (DataCon con) args (idType binder))
 440 \end{code}
 441
 442 Little helper for primitives that return unboxed tuples.
 443
 444
 445 \begin{code}
 446 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
 447 primRetUnboxedTuple op args res_ty
 448   = getArgAmodes args       `thenFC` \ arg_amodes ->
 449     {-
 450       put all the arguments in temporaries so they don't get stomped when
 451       we push the return address.
 452     -}
 453     let
 454       n_args              = length args
 455       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 456       arg_reps            = map getArgPrimRep args
 457       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 458     in
 459     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 460     {-
 461       allocate some temporaries for the return values.
 462     -}
 463     let
 464       (tc,ty_args)      = case splitTyConAppThroughNewTypes res_ty of
 465                             Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 466                             Just pr -> pr
 467       prim_reps          = map typePrimRep ty_args
 468       temp_uniqs         = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 469       temp_amodes        = zipWith CTemp temp_uniqs prim_reps
 470     in
 471     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 472
 473 \end{code}