ghc/compiler/codeGen/CgExpr.lhs

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