ghc/compiler/codeGen/CgExpr.lhs

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