ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.54 2003/07/02 13:12:36 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, getAmodeRep )
  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, 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, 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 TysPrim          ( foreignObjPrimTyCon, arrayPrimTyCon,
  45                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
  46                           mutableArrayPrimTyCon )
  47 import PrimRep          ( PrimRep(..), isFollowableRep )
  48 import TyCon            ( isUnboxedTupleTyCon, isEnumerationTyCon )
  49 import Type             ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
  50 import Maybes           ( maybeToBool )
  51 import ListSetOps       ( assocMaybe )
  52 import Unique           ( mkBuiltinUnique )
  53 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  54 import Util             ( lengthIs )
  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 (StgConApp con args)
  89   = getArgAmodes args `thenFC` \ amodes ->
  90     cgReturnDataCon con amodes
  91 \end{code}
  92
  93 Literals are similar to constructors; they return by putting
  94 themselves in an appropriate register and returning to the address on
  95 top of the stack.
  96
  97 \begin{code}
  98 cgExpr (StgLit lit)
  99   = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
 100 \end{code}
 101
 102
 103 %********************************************************
 104 %*                                                      *
 105 %*              STG PrimApps  (unboxed primitive ops)   *
 106 %*                                                      *
 107 %********************************************************
 108
 109 Here is where we insert real live machine instructions.
 110
 111 NOTE about _ccall_GC_:
 112
 113 A _ccall_GC_ is treated as an out-of-line primop (returns True
 114 for primOpOutOfLine) so that when we see the call in case context
 115         case (ccall ...) of { ... }
 116 we get a proper stack frame on the stack when we perform it.  When we
 117 get in a tail-call position, however, we need to actually perform the
 118 call, so we treat it as an inline primop.
 119
 120 \begin{code}
 121 cgExpr (StgOpApp op@(StgFCallOp _ _) 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 (StgOpApp (StgPrimOp 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                         (CVal (CIndex
 136                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 137                           dyn_tag PtrRep) PtrRep))
 138             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 139    where
 140         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 141                 -- The '0' is just to get a random spare temp
 142           --
 143           -- if you're reading this code in the attempt to figure
 144           -- out why the compiler panic'ed here, it is probably because
 145           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 146           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 147           --
 148           -- That won't work.
 149           --
 150         tycon = tyConAppTyCon res_ty
 151
 152
 153 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 154   | primOpOutOfLine primop
 155   = tailCallPrimOp primop args
 156
 157   | otherwise
 158   = getArgAmodes args   `thenFC` \ arg_amodes ->
 159
 160     case (getPrimOpResultInfo primop) of
 161
 162         ReturnsPrim kind ->
 163             let result_amode = CReg (dataReturnConvPrim kind) in
 164             performReturn
 165               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 166               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 167
 168         -- otherwise, must be returning an enumerated type (eg. Bool).
 169         -- we've only got the tag in R2, so we have to load the constructor
 170         -- itself into R1.
 171
 172         ReturnsAlg tycon
 173             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 174
 175             | isEnumerationTyCon  tycon ->
 176                 performReturn
 177                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 178                           (\ sequel ->
 179                           absC (CAssign (CReg node) closure_lbl) `thenC`
 180                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 181
 182             where
 183                -- Pull a unique out of thin air to put the tag in.
 184                -- It shouldn't matter if this overlaps with anything - we're
 185                -- about to return anyway.
 186                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 187
 188                closure_lbl = CVal (CIndex
 189                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 190                                dyn_tag PtrRep) PtrRep
 191
 192 \end{code}
 193
 194 %********************************************************
 195 %*                                                      *
 196 %*              Case expressions                        *
 197 %*                                                      *
 198 %********************************************************
 199 Case-expression conversion is complicated enough to have its own
 200 module, @CgCase@.
 201 \begin{code}
 202
 203 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
 204   = cgCase expr live_vars save_vars bndr srt alt_type alts
 205 \end{code}
 206
 207
 208 %********************************************************
 209 %*                                                      *
 210 %*              Let and letrec                          *
 211 %*                                                      *
 212 %********************************************************
 213 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 214
 215 \begin{code}
 216 cgExpr (StgLet (StgNonRec name rhs) expr)
 217   = cgRhs name rhs      `thenFC` \ (name, info) ->
 218     addBindC name info  `thenC`
 219     cgExpr expr
 220
 221 cgExpr (StgLet (StgRec pairs) expr)
 222   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 223                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 224     ) `thenFC` \ new_bindings ->
 225
 226     addBindsC new_bindings `thenC`
 227     cgExpr expr
 228 \end{code}
 229
 230 \begin{code}
 231 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 232   =     -- Figure out what volatile variables to save
 233     nukeDeadBindings live_in_whole_let  `thenC`
 234     saveVolatileVarsAndRegs live_in_rhss
 235             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 236
 237         -- TEMP: put back in for line-by-line compatibility
 238         -- Doesn't look right; surely should restore in the branch!
 239         -- And the code isn't used....
 240     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 241
 242         -- Save those variables right now!
 243     absC save_assts                             `thenC`
 244
 245         -- Produce code for the rhss
 246         -- and add suitable bindings to the environment
 247     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 248
 249         -- Do the body
 250     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 251 \end{code}
 252
 253
 254 %********************************************************
 255 %*                                                      *
 256 %*              SCC Expressions                         *
 257 %*                                                      *
 258 %********************************************************
 259
 260 SCC expressions are treated specially. They set the current cost
 261 centre.
 262 \begin{code}
 263 cgExpr (StgSCC cc expr)
 264   = ASSERT(sccAbleCostCentre cc)
 265     costCentresC
 266         FSLIT("SET_CCC")
 267         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 268     `thenC`
 269     cgExpr expr
 270 \end{code}
 271
 272 ToDo: counting of dict sccs ...
 273
 274 %********************************************************
 275 %*                                                      *
 276 %*              Non-top-level bindings                  *
 277 %*                                                      *
 278 %********************************************************
 279 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 280
 281 We rely on the support code in @CgCon@ (to do constructors) and
 282 in @CgClosure@ (to do closures).
 283
 284 \begin{code}
 285 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 286         -- the Id is passed along so a binding can be set up
 287
 288 cgRhs name (StgRhsCon maybe_cc con args)
 289   = getArgAmodes args                           `thenFC` \ amodes ->
 290     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 291     returnFC (name, idinfo)
 292
 293 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
 294   = mkRhsClosure name cc bi srt fvs upd_flag args body
 295 \end{code}
 296
 297 mkRhsClosure looks for two special forms of the right-hand side:
 298         a) selector thunks.
 299         b) AP thunks
 300
 301 If neither happens, it just calls mkClosureLFInfo.  You might think
 302 that mkClosureLFInfo should do all this, but it seems wrong for the
 303 latter to look at the structure of an expression
 304
 305 Selectors
 306 ~~~~~~~~~
 307 We look at the body of the closure to see if it's a selector---turgid,
 308 but nothing deep.  We are looking for a closure of {\em exactly} the
 309 form:
 310
 311 ...  = [the_fv] \ u [] ->
 312          case the_fv of
 313            con a_1 ... a_n -> a_i
 314
 315
 316 \begin{code}
 317 mkRhsClosure    bndr cc bi srt
 318                 [the_fv]                -- Just one free var
 319                 upd_flag                -- Updatable thunk
 320                 []                      -- A thunk
 321                 body@(StgCase (StgApp scrutinee [{-no args-}])
 322                       _ _ _ _   -- ignore uniq, etc.
 323                       (AlgAlt tycon)
 324                       [(DataAlt con, params, use_mask,
 325                             (StgApp selectee [{-no args-}]))])
 326   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 327   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 328   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 329   = -- NOT TRUE: ASSERT(is_single_constructor)
 330     -- The simplifier may have statically determined that the single alternative
 331     -- is the only possible case and eliminated the others, even if there are
 332     -- other constructors in the datatype.  It's still ok to make a selector
 333     -- thunk in this case, because we *know* which constructor the scrutinee
 334     -- will evaluate to.
 335     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 336   where
 337     lf_info               = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
 338     (_, params_w_offsets) = layOutDynConstr con idPrimRep params
 339                                 -- Just want the layout
 340     maybe_offset          = assocMaybe params_w_offsets selectee
 341     Just the_offset       = maybe_offset
 342     offset_into_int       = the_offset - fixedHdrSize
 343 \end{code}
 344
 345 Ap thunks
 346 ~~~~~~~~~
 347
 348 A more generic AP thunk of the form
 349
 350         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 351
 352 A set of these is compiled statically into the RTS, so we just use
 353 those.  We could extend the idea to thunks where some of the x_i are
 354 global ids (and hence not free variables), but this would entail
 355 generating a larger thunk.  It might be an option for non-optimising
 356 compilation, though.
 357
 358 We only generate an Ap thunk if all the free variables are pointers,
 359 for semi-obvious reasons.
 360
 361 \begin{code}
 362 mkRhsClosure    bndr cc bi srt
 363                 fvs
 364                 upd_flag
 365                 []                      -- No args; a thunk
 366                 body@(StgApp fun_id args)
 367
 368   | args `lengthIs` (arity-1)
 369         && all isFollowableRep (map idPrimRep fvs)
 370         && isUpdatable upd_flag
 371         && arity <= mAX_SPEC_AP_SIZE
 372
 373                    -- Ha! an Ap thunk
 374         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 375
 376    where
 377         lf_info = mkApLFInfo bndr upd_flag arity
 378         -- the payload has to be in the correct order, hence we can't
 379         -- just use the fvs.
 380         payload    = StgVarArg fun_id : args
 381         arity      = length fvs
 382 \end{code}
 383
 384 The default case
 385 ~~~~~~~~~~~~~~~~
 386 \begin{code}
 387 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 388   = cgRhsClosure bndr cc bi srt fvs args body lf_info
 389   where
 390     lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 391 \end{code}
 392
 393
 394 %********************************************************
 395 %*                                                      *
 396 %*              Let-no-escape bindings
 397 %*                                                      *
 398 %********************************************************
 399 \begin{code}
 400 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 401         (StgNonRec binder rhs)
 402   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 403                      NonRecursive binder rhs
 404                                 `thenFC` \ (binder, info) ->
 405     addBindC binder info
 406
 407 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 408   = fixC (\ new_bindings ->
 409                 addBindsC new_bindings  `thenC`
 410                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 411                                 rhs_eob_info maybe_cc_slot Recursive b e
 412                         | (b,e) <- pairs ]
 413     ) `thenFC` \ new_bindings ->
 414
 415     addBindsC new_bindings
 416   where
 417     -- We add the binders to the live-in-rhss set so that we don't
 418     -- delete the bindings for the binder from the environment!
 419     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 420
 421 cgLetNoEscapeRhs
 422     :: StgLiveVars      -- Live in rhss
 423     -> EndOfBlockInfo
 424     -> Maybe VirtualSpOffset
 425     -> RecFlag
 426     -> Id
 427     -> StgRhs
 428     -> FCode (Id, CgIdInfo)
 429
 430 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 431                  (StgRhsClosure cc bi _ upd_flag srt args body)
 432   = -- We could check the update flag, but currently we don't switch it off
 433     -- for let-no-escaped things, so we omit the check too!
 434     -- case upd_flag of
 435     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 436     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 437     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 438         maybe_cc_slot rec args body
 439
 440 -- For a constructor RHS we want to generate a single chunk of code which
 441 -- can be jumped to from many places, which will return the constructor.
 442 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 443 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 444                  (StgRhsCon cc con args)
 445   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
 446                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 447         []      --No args; the binder is data structure, not a function
 448         (StgConApp con args)
 449 \end{code}
 450
 451 Little helper for primitives that return unboxed tuples.
 452
 453
 454 \begin{code}
 455 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 456 primRetUnboxedTuple op args res_ty
 457   = getArgAmodes args       `thenFC` \ arg_amodes1 ->
 458     {-
 459       For a foreign call, we might need to fiddle with some of the args:
 460       for example, when passing a ByteArray#, we pass a ptr to the goods
 461       rather than the heap object.
 462     -}
 463     let
 464         arg_amodes
 465           | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
 466           | otherwise          = arg_amodes1
 467     in
 468     {-
 469       put all the arguments in temporaries so they don't get stomped when
 470       we push the return address.
 471     -}
 472     let
 473       n_args              = length args
 474       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 475       arg_reps            = map getAmodeRep arg_amodes
 476       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 477     in
 478     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 479     {-
 480       allocate some temporaries for the return values.
 481     -}
 482     let
 483       ty_args     = tyConAppArgs (repType res_ty)
 484       prim_reps   = map typePrimRep ty_args
 485       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 486       temp_amodes = zipWith CTemp temp_uniqs prim_reps
 487     in
 488     ccallReturnUnboxedTuple temp_amodes
 489         (absC (COpStmt temp_amodes op arg_temps []))
 490
 491
 492 shimFCallArg arg amode
 493   | tycon == foreignObjPrimTyCon
 494         = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
 495   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 496         = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
 497   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 498         = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
 499   | otherwise = amode
 500   where
 501         -- should be a tycon app, since this is a foreign call
 502         tycon = tyConAppTyCon (repType (stgArgType arg))
 503 \end{code}