ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.49 2002/06/18 13:58:23 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,
  26                           nukeDeadBindings, addBindC, addBindsC )
  27 import CgCase           ( cgCase, saveVolatileVarsAndRegs,
  28                           restoreCurrentCostCentre )
  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, layOutDynConstr )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, idType, Id )
  41 import VarSet
  42 import PrimOp           ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
  43 import PrimRep          ( PrimRep(..), isFollowableRep )
  44 import TyCon            ( isUnboxedTupleTyCon, isEnumerationTyCon )
  45 import Type             ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
  46 import Maybes           ( maybeToBool )
  47 import ListSetOps       ( assocMaybe )
  48 import Unique           ( mkBuiltinUnique )
  49 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  50 import Util             ( lengthIs )
  51 import Outputable
  52 \end{code}
  53
  54 This module provides the support code for @StgToAbstractC@ to deal
  55 with STG {\em expressions}.  See also @CgClosure@, which deals
  56 with closures, and @CgCon@, which deals with constructors.
  57
  58 \begin{code}
  59 cgExpr  :: StgExpr              -- input
  60         -> Code                 -- output
  61 \end{code}
  62
  63 %********************************************************
  64 %*                                                      *
  65 %*              Tail calls                              *
  66 %*                                                      *
  67 %********************************************************
  68
  69 ``Applications'' mean {\em tail calls}, a service provided by module
  70 @CgTailCall@.  This includes literals, which show up as
  71 @(STGApp (StgLitArg 42) [])@.
  72
  73 \begin{code}
  74 cgExpr (StgApp fun args) = cgTailCall fun args
  75 \end{code}
  76
  77 %********************************************************
  78 %*                                                      *
  79 %*              STG ConApps  (for inline versions)      *
  80 %*                                                      *
  81 %********************************************************
  82
  83 \begin{code}
  84 cgExpr (StgConApp con args)
  85   = getArgAmodes args `thenFC` \ amodes ->
  86     cgReturnDataCon con amodes
  87 \end{code}
  88
  89 Literals are similar to constructors; they return by putting
  90 themselves in an appropriate register and returning to the address on
  91 top of the stack.
  92
  93 \begin{code}
  94 cgExpr (StgLit lit)
  95   = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
  96 \end{code}
  97
  98
  99 %********************************************************
 100 %*                                                      *
 101 %*              STG PrimApps  (unboxed primitive ops)   *
 102 %*                                                      *
 103 %********************************************************
 104
 105 Here is where we insert real live machine instructions.
 106
 107 NOTE about _ccall_GC_:
 108
 109 A _ccall_GC_ is treated as an out-of-line primop (returns True
 110 for primOpOutOfLine) so that when we see the call in case context
 111         case (ccall ...) of { ... }
 112 we get a proper stack frame on the stack when we perform it.  When we
 113 get in a tail-call position, however, we need to actually perform the
 114 call, so we treat it as an inline primop.
 115
 116 \begin{code}
 117 cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
 118   = primRetUnboxedTuple op args res_ty
 119
 120 -- tagToEnum# is special: we need to pull the constructor out of the table,
 121 -- and perform an appropriate return.
 122
 123 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 124   = ASSERT(isEnumerationTyCon tycon)
 125     getArgAmode arg `thenFC` \amode ->
 126         -- save the tag in a temporary in case amode overlaps
 127         -- with node.
 128     absC (CAssign dyn_tag amode)        `thenC`
 129     performReturn (
 130                 CAssign (CReg node)
 131                         (CVal (CIndex
 132                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 133                           dyn_tag PtrRep) PtrRep))
 134             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 135    where
 136         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 137           --
 138           -- if you're reading this code in the attempt to figure
 139           -- out why the compiler panic'ed here, it is probably because
 140           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 141           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 142           --
 143           -- That won't work.
 144           --
 145         tycon = tyConAppTyCon res_ty
 146
 147
 148 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 149   | primOpOutOfLine primop
 150   = tailCallPrimOp primop args
 151
 152   | otherwise
 153   = getArgAmodes args   `thenFC` \ arg_amodes ->
 154
 155     case (getPrimOpResultInfo primop) of
 156
 157         ReturnsPrim kind ->
 158             let result_amode = CReg (dataReturnConvPrim kind) in
 159             performReturn
 160               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 161               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 162
 163         -- otherwise, must be returning an enumerated type (eg. Bool).
 164         -- we've only got the tag in R2, so we have to load the constructor
 165         -- itself into R1.
 166
 167         ReturnsAlg tycon
 168             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 169
 170             | isEnumerationTyCon  tycon ->
 171                 performReturn
 172                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 173                           (\ sequel ->
 174                           absC (CAssign (CReg node) closure_lbl) `thenC`
 175                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 176
 177             where
 178                -- Pull a unique out of thin air to put the tag in.
 179                -- It shouldn't matter if this overlaps with anything - we're
 180                -- about to return anyway.
 181                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 182
 183                closure_lbl = CVal (CIndex
 184                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 185                                dyn_tag PtrRep) PtrRep
 186
 187 \end{code}
 188
 189 %********************************************************
 190 %*                                                      *
 191 %*              Case expressions                        *
 192 %*                                                      *
 193 %********************************************************
 194 Case-expression conversion is complicated enough to have its own
 195 module, @CgCase@.
 196 \begin{code}
 197
 198 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 199   = cgCase expr live_vars save_vars bndr srt alts
 200 \end{code}
 201
 202
 203 %********************************************************
 204 %*                                                      *
 205 %*              Let and letrec                          *
 206 %*                                                      *
 207 %********************************************************
 208 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 209
 210 \begin{code}
 211 cgExpr (StgLet (StgNonRec srt name rhs) expr)
 212   = cgRhs srt name rhs  `thenFC` \ (name, info) ->
 213     addBindC name info  `thenC`
 214     cgExpr expr
 215
 216 cgExpr (StgLet (StgRec srt pairs) expr)
 217   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 218                             listFCs [ cgRhs srt b e | (b,e) <- pairs ]
 219     ) `thenFC` \ new_bindings ->
 220
 221     addBindsC new_bindings `thenC`
 222     cgExpr expr
 223 \end{code}
 224
 225 \begin{code}
 226 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 227   =     -- Figure out what volatile variables to save
 228     nukeDeadBindings live_in_whole_let  `thenC`
 229     saveVolatileVarsAndRegs live_in_rhss
 230             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 231     -- ToDo: cost centre???
 232     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 233
 234         -- Save those variables right now!
 235     absC save_assts                             `thenC`
 236
 237         -- Produce code for the rhss
 238         -- and add suitable bindings to the environment
 239     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 240
 241         -- Do the body
 242     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 243 \end{code}
 244
 245
 246 %********************************************************
 247 %*                                                      *
 248 %*              SCC Expressions                         *
 249 %*                                                      *
 250 %********************************************************
 251
 252 SCC expressions are treated specially. They set the current cost
 253 centre.
 254 \begin{code}
 255 cgExpr (StgSCC cc expr)
 256   = ASSERT(sccAbleCostCentre cc)
 257     costCentresC
 258         FSLIT("SET_CCC")
 259         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 260     `thenC`
 261     cgExpr expr
 262 \end{code}
 263
 264 ToDo: counting of dict sccs ...
 265
 266 %********************************************************
 267 %*                                                      *
 268 %*              Non-top-level bindings                  *
 269 %*                                                      *
 270 %********************************************************
 271 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 272
 273 We rely on the support code in @CgCon@ (to do constructors) and
 274 in @CgClosure@ (to do closures).
 275
 276 \begin{code}
 277 cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
 278         -- the Id is passed along so a binding can be set up
 279
 280 cgRhs srt name (StgRhsCon maybe_cc con args)
 281   = getArgAmodes args                           `thenFC` \ amodes ->
 282     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 283     returnFC (name, idinfo)
 284
 285 cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
 286   = mkRhsClosure name cc bi srt fvs upd_flag args body
 287 \end{code}
 288
 289 mkRhsClosure looks for two special forms of the right-hand side:
 290         a) selector thunks.
 291         b) AP thunks
 292
 293 If neither happens, it just calls mkClosureLFInfo.  You might think
 294 that mkClosureLFInfo should do all this, but it seems wrong for the
 295 latter to look at the structure of an expression
 296
 297 Selectors
 298 ~~~~~~~~~
 299 We look at the body of the closure to see if it's a selector---turgid,
 300 but nothing deep.  We are looking for a closure of {\em exactly} the
 301 form:
 302
 303 ...  = [the_fv] \ u [] ->
 304          case the_fv of
 305            con a_1 ... a_n -> a_i
 306
 307
 308 \begin{code}
 309 mkRhsClosure    bndr cc bi srt
 310                 [the_fv]                -- Just one free var
 311                 upd_flag                -- Updatable thunk
 312                 []                      -- A thunk
 313                 body@(StgCase (StgApp scrutinee [{-no args-}])
 314                       _ _ _ _   -- ignore uniq, etc.
 315                       (StgAlgAlts (Just tycon)
 316                          [(con, params, use_mask,
 317                             (StgApp selectee [{-no args-}]))]
 318                          StgNoDefault))
 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 (idType bndr) offset_into_int
 331                                                 (isUpdatable upd_flag)
 332     (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
 333                                 -- Just want the layout
 334     maybe_offset          = assocMaybe params_w_offsets selectee
 335     Just the_offset       = maybe_offset
 336     offset_into_int       = the_offset - fixedHdrSize
 337     bogus_name            = panic "mkRhsClosure"
 338 \end{code}
 339
 340 Ap thunks
 341 ~~~~~~~~~
 342
 343 A more generic AP thunk of the form
 344
 345         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 346
 347 A set of these is compiled statically into the RTS, so we just use
 348 those.  We could extend the idea to thunks where some of the x_i are
 349 global ids (and hence not free variables), but this would entail
 350 generating a larger thunk.  It might be an option for non-optimising
 351 compilation, though.
 352
 353 We only generate an Ap thunk if all the free variables are pointers,
 354 for semi-obvious reasons.
 355
 356 \begin{code}
 357 mkRhsClosure    bndr cc bi srt
 358                 fvs
 359                 upd_flag
 360                 []                      -- No args; a thunk
 361                 body@(StgApp fun_id args)
 362
 363   | args `lengthIs` (arity-1)
 364         && all isFollowableRep (map idPrimRep fvs)
 365         && isUpdatable upd_flag
 366         && arity <= mAX_SPEC_AP_SIZE
 367
 368                    -- Ha! an Ap thunk
 369         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 370
 371    where
 372         lf_info = mkApLFInfo (idType bndr) upd_flag arity
 373         -- the payload has to be in the correct order, hence we can't
 374         -- just use the fvs.
 375         payload    = StgVarArg fun_id : args
 376         arity      = length fvs
 377 \end{code}
 378
 379 The default case
 380 ~~~~~~~~~~~~~~~~
 381 \begin{code}
 382 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 383   = cgRhsClosure bndr cc bi srt fvs args body lf_info
 384   where
 385     lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 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
 396         (StgNonRec srt binder rhs)
 397   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 398                         NonRecursive srt binder rhs
 399                                 `thenFC` \ (binder, info) ->
 400     addBindC binder info
 401
 402 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 403         (StgRec srt pairs)
 404   = fixC (\ new_bindings ->
 405                 addBindsC new_bindings  `thenC`
 406                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 407                                 rhs_eob_info maybe_cc_slot Recursive srt b e
 408                         | (b,e) <- pairs ]
 409     ) `thenFC` \ new_bindings ->
 410
 411     addBindsC new_bindings
 412   where
 413     -- We add the binders to the live-in-rhss set so that we don't
 414     -- delete the bindings for the binder from the environment!
 415     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 416
 417 cgLetNoEscapeRhs
 418     :: StgLiveVars      -- Live in rhss
 419     -> EndOfBlockInfo
 420     -> Maybe VirtualSpOffset
 421     -> RecFlag
 422     -> SRT
 423     -> Id
 424     -> StgRhs
 425     -> FCode (Id, CgIdInfo)
 426
 427 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 428                  (StgRhsClosure cc bi _ upd_flag args body)
 429   = -- We could check the update flag, but currently we don't switch it off
 430     -- for let-no-escaped things, so we omit the check too!
 431     -- case upd_flag of
 432     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 433     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 434     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 435         maybe_cc_slot rec args body
 436
 437 -- For a constructor RHS we want to generate a single chunk of code which
 438 -- can be jumped to from many places, which will return the constructor.
 439 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 440 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 441                  (StgRhsCon cc con args)
 442   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
 443                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 444         []      --No args; the binder is data structure, not a function
 445         (StgConApp con args)
 446 \end{code}
 447
 448 Little helper for primitives that return unboxed tuples.
 449
 450
 451 \begin{code}
 452 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 453 primRetUnboxedTuple op args res_ty
 454   = getArgAmodes args       `thenFC` \ arg_amodes ->
 455     {-
 456       put all the arguments in temporaries so they don't get stomped when
 457       we push the return address.
 458     -}
 459     let
 460       n_args              = length args
 461       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 462       arg_reps            = map getArgPrimRep args
 463       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 464     in
 465     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 466     {-
 467       allocate some temporaries for the return values.
 468     -}
 469     let
 470       ty_args     = tyConAppArgs (repType res_ty)
 471       prim_reps   = map typePrimRep ty_args
 472       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 473       temp_amodes = zipWith CTemp temp_uniqs prim_reps
 474     in
 475     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 476 \end{code}