ghc/compiler/codeGen/CgExpr.lhs

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