ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.58 2004/08/10 09:02:41 simonmar 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, getAmodeRep, shimFCallArg )
  22 import CLabel           ( mkClosureTblLabel )
  23
  24 import SMRep            ( fixedHdrSize )
  25 import CoreSyn          ( AltCon(..) )
  26 import CgBindery        ( getArgAmodes, getArgAmode, CgIdInfo,
  27                           nukeDeadBindings, addBindC, addBindsC )
  28 import CgCase           ( cgCase, saveVolatileVarsAndRegs )
  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, ccallReturnUnboxedTuple
  36                         )
  37 import ClosureInfo      ( mkClosureLFInfo, mkSelectorLFInfo,
  38                           mkApLFInfo, layOutDynConstr )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, Id )
  41 import VarSet
  42 import PrimOp           ( primOpOutOfLine, getPrimOpResultInfo,
  43                           PrimOp(..), PrimOpResultInfo(..) )
  44 import PrimRep          ( PrimRep(..), isFollowableRep )
  45 import TyCon            ( isUnboxedTupleTyCon, isEnumerationTyCon )
  46 import Type             ( Type, typePrimRep, tyConAppArgs,
  47                           tyConAppTyCon, repType )
  48 import Maybes           ( maybeToBool )
  49 import ListSetOps       ( assocMaybe )
  50 import Unique           ( mkBuiltinUnique )
  51 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  52 import Util             ( lengthIs )
  53 import Outputable
  54 \end{code}
  55
  56 This module provides the support code for @StgToAbstractC@ to deal
  57 with STG {\em expressions}.  See also @CgClosure@, which deals
  58 with closures, and @CgCon@, which deals with constructors.
  59
  60 \begin{code}
  61 cgExpr  :: StgExpr              -- input
  62         -> Code                 -- output
  63 \end{code}
  64
  65 %********************************************************
  66 %*                                                      *
  67 %*              Tail calls                              *
  68 %*                                                      *
  69 %********************************************************
  70
  71 ``Applications'' mean {\em tail calls}, a service provided by module
  72 @CgTailCall@.  This includes literals, which show up as
  73 @(STGApp (StgLitArg 42) [])@.
  74
  75 \begin{code}
  76 cgExpr (StgApp fun args) = cgTailCall fun args
  77 \end{code}
  78
  79 %********************************************************
  80 %*                                                      *
  81 %*              STG ConApps  (for inline versions)      *
  82 %*                                                      *
  83 %********************************************************
  84
  85 \begin{code}
  86 cgExpr (StgConApp con args)
  87   = getArgAmodes args `thenFC` \ amodes ->
  88     cgReturnDataCon con amodes
  89 \end{code}
  90
  91 Literals are similar to constructors; they return by putting
  92 themselves in an appropriate register and returning to the address on
  93 top of the stack.
  94
  95 \begin{code}
  96 cgExpr (StgLit lit)
  97   = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
  98 \end{code}
  99
 100
 101 %********************************************************
 102 %*                                                      *
 103 %*              STG PrimApps  (unboxed primitive ops)   *
 104 %*                                                      *
 105 %********************************************************
 106
 107 Here is where we insert real live machine instructions.
 108
 109 NOTE about _ccall_GC_:
 110
 111 A _ccall_GC_ is treated as an out-of-line primop (returns True
 112 for primOpOutOfLine) so that when we see the call in case context
 113         case (ccall ...) of { ... }
 114 we get a proper stack frame on the stack when we perform it.  When we
 115 get in a tail-call position, however, we need to actually perform the
 116 call, so we treat it as an inline primop.
 117
 118 \begin{code}
 119 cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
 120   = primRetUnboxedTuple op args res_ty
 121
 122 -- tagToEnum# is special: we need to pull the constructor out of the table,
 123 -- and perform an appropriate return.
 124
 125 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 126   = ASSERT(isEnumerationTyCon tycon)
 127     getArgAmode arg `thenFC` \amode ->
 128         -- save the tag in a temporary in case amode overlaps
 129         -- with node.
 130     absC (CAssign dyn_tag amode)        `thenC`
 131     performReturn (
 132                 CAssign (CReg node)
 133                         (CVal (CIndex
 134                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 135                           dyn_tag PtrRep) PtrRep))
 136             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 137    where
 138         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 139                 -- The '0' is just to get a random spare temp
 140           --
 141           -- if you're reading this code in the attempt to figure
 142           -- out why the compiler panic'ed here, it is probably because
 143           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 144           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 145           --
 146           -- That won't work.
 147           --
 148         tycon = tyConAppTyCon res_ty
 149
 150
 151 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 152   | primOpOutOfLine primop
 153   = tailCallPrimOp primop args
 154
 155   | otherwise
 156   = getArgAmodes args   `thenFC` \ arg_amodes ->
 157
 158     case (getPrimOpResultInfo primop) of
 159
 160         ReturnsPrim kind ->
 161             let result_amode = CReg (dataReturnConvPrim kind) in
 162             performReturn
 163               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 164               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 165
 166         -- otherwise, must be returning an enumerated type (eg. Bool).
 167         -- we've only got the tag in R2, so we have to load the constructor
 168         -- itself into R1.
 169
 170         ReturnsAlg tycon
 171             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 172
 173             | isEnumerationTyCon  tycon ->
 174                 performReturn
 175                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 176                           (\ sequel ->
 177                           absC (CAssign (CReg node) closure_lbl) `thenC`
 178                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 179
 180             where
 181                -- Pull a unique out of thin air to put the tag in.
 182                -- It shouldn't matter if this overlaps with anything - we're
 183                -- about to return anyway.
 184                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 185
 186                closure_lbl = CVal (CIndex
 187                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 188                                dyn_tag PtrRep) PtrRep
 189
 190 \end{code}
 191
 192 %********************************************************
 193 %*                                                      *
 194 %*              Case expressions                        *
 195 %*                                                      *
 196 %********************************************************
 197 Case-expression conversion is complicated enough to have its own
 198 module, @CgCase@.
 199 \begin{code}
 200
 201 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
 202   = cgCase expr live_vars save_vars bndr srt alt_type alts
 203 \end{code}
 204
 205
 206 %********************************************************
 207 %*                                                      *
 208 %*              Let and letrec                          *
 209 %*                                                      *
 210 %********************************************************
 211 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 212
 213 \begin{code}
 214 cgExpr (StgLet (StgNonRec name rhs) expr)
 215   = cgRhs name rhs      `thenFC` \ (name, info) ->
 216     addBindC name info  `thenC`
 217     cgExpr expr
 218
 219 cgExpr (StgLet (StgRec pairs) expr)
 220   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 221                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 222     ) `thenFC` \ new_bindings ->
 223
 224     addBindsC new_bindings `thenC`
 225     cgExpr expr
 226 \end{code}
 227
 228 \begin{code}
 229 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 230   =     -- Figure out what volatile variables to save
 231     nukeDeadBindings live_in_whole_let  `thenC`
 232     saveVolatileVarsAndRegs live_in_rhss
 233             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 234
 235         -- Save those variables right now!
 236     absC save_assts                             `thenC`
 237
 238         -- Produce code for the rhss
 239         -- and add suitable bindings to the environment
 240     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 241
 242         -- Do the body
 243     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 244 \end{code}
 245
 246
 247 %********************************************************
 248 %*                                                      *
 249 %*              SCC Expressions                         *
 250 %*                                                      *
 251 %********************************************************
 252
 253 SCC expressions are treated specially. They set the current cost
 254 centre.
 255 \begin{code}
 256 cgExpr (StgSCC cc expr)
 257   = ASSERT(sccAbleCostCentre cc)
 258     costCentresC
 259         FSLIT("SET_CCC")
 260         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 261     `thenC`
 262     cgExpr expr
 263 \end{code}
 264
 265 ToDo: counting of dict sccs ...
 266
 267 %********************************************************
 268 %*                                                      *
 269 %*              Non-top-level bindings                  *
 270 %*                                                      *
 271 %********************************************************
 272 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 273
 274 We rely on the support code in @CgCon@ (to do constructors) and
 275 in @CgClosure@ (to do closures).
 276
 277 \begin{code}
 278 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 279         -- the Id is passed along so a binding can be set up
 280
 281 cgRhs name (StgRhsCon maybe_cc con args)
 282   = getArgAmodes args                           `thenFC` \ amodes ->
 283     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 284     returnFC (name, idinfo)
 285
 286 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt 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                       (AlgAlt tycon)
 317                       [(DataAlt con, params, use_mask,
 318                             (StgApp selectee [{-no args-}]))])
 319   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 320   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 321   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 322   = -- NOT TRUE: ASSERT(is_single_constructor)
 323     -- The simplifier may have statically determined that the single alternative
 324     -- is the only possible case and eliminated the others, even if there are
 325     -- other constructors in the datatype.  It's still ok to make a selector
 326     -- thunk in this case, because we *know* which constructor the scrutinee
 327     -- will evaluate to.
 328     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 329   where
 330     lf_info               = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
 331     (_, params_w_offsets) = layOutDynConstr con idPrimRep params
 332                                 -- Just want the layout
 333     maybe_offset          = assocMaybe params_w_offsets selectee
 334     Just the_offset       = maybe_offset
 335     offset_into_int       = the_offset - fixedHdrSize
 336 \end{code}
 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   | args `lengthIs` (arity-1)
 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 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   = cgRhsClosure bndr cc bi srt fvs args body lf_info
 382   where
 383     lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 384 \end{code}
 385
 386
 387 %********************************************************
 388 %*                                                      *
 389 %*              Let-no-escape bindings
 390 %*                                                      *
 391 %********************************************************
 392 \begin{code}
 393 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 394         (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 _ upd_flag srt 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
 431         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 noBinderInfo{-safe-} NoSRT
 439                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 440         []      --No args; the binder is data structure, not a function
 441         (StgConApp con args)
 442 \end{code}
 443
 444 Little helper for primitives that return unboxed tuples.
 445
 446
 447 \begin{code}
 448 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 449 primRetUnboxedTuple op args res_ty
 450   = getArgAmodes args       `thenFC` \ arg_amodes1 ->
 451     {-
 452       For a foreign call, we might need to fiddle with some of the args:
 453       for example, when passing a ByteArray#, we pass a ptr to the goods
 454       rather than the heap object.
 455     -}
 456     let
 457         arg_amodes
 458           | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
 459           | otherwise          = arg_amodes1
 460     in
 461     {-
 462       put all the arguments in temporaries so they don't get stomped when
 463       we push the return address.
 464     -}
 465     let
 466       n_args              = length args
 467       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 468       arg_reps            = map getAmodeRep arg_amodes
 469       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 470     in
 471     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 472     {-
 473       allocate some temporaries for the return values.
 474     -}
 475     let
 476       ty_args     = tyConAppArgs (repType res_ty)
 477       prim_reps   = map typePrimRep ty_args
 478       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 479       temp_amodes = zipWith CTemp temp_uniqs prim_reps
 480     in
 481     ccallReturnUnboxedTuple temp_amodes
 482         (absC (COpStmt temp_amodes op arg_temps []))
 483 \end{code}