ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.30 1999/10/25 13:21:16 sof 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, layOutDynCon )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, idType, Id )
  41 import VarSet
  42 import DataCon          ( DataCon, dataConTyCon )
  43 import Const            ( Con(..) )
  44 import IdInfo           ( ArityInfo(..) )
  45 import PrimOp           ( primOpOutOfLine,
  46                           getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
  47                         )
  48 import PrimRep          ( getPrimRepSize, PrimRep(..), isFollowableRep )
  49 import TyCon            ( maybeTyConSingleCon,
  50                           isUnboxedTupleTyCon, isEnumerationTyCon )
  51 import Type             ( Type, typePrimRep, splitTyConApp_maybe, repType )
  52 import Maybes           ( assocMaybe, maybeToBool )
  53 import Unique           ( mkBuiltinUnique )
  54 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  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 (StgCon (DataCon con) args res_ty)
  89   = getArgAmodes args `thenFC` \ amodes ->
  90     cgReturnDataCon con amodes (all zero_size args)
  91   where
  92     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
  93 \end{code}
  94
  95 Literals are similar to constructors; they return by putting
  96 themselves in an appropriate register and returning to the address on
  97 top of the stack.
  98
  99 \begin{code}
 100 cgExpr (StgCon (Literal lit) args res_ty)
 101   = ASSERT( null args )
 102     performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
 103 \end{code}
 104
 105
 106 %********************************************************
 107 %*                                                      *
 108 %*              STG PrimApps  (unboxed primitive ops)   *
 109 %*                                                      *
 110 %********************************************************
 111
 112 Here is where we insert real live machine instructions.
 113
 114 NOTE about _ccall_GC_:
 115
 116 A _ccall_GC_ is treated as an out-of-line primop for the case
 117 expression code, because we want a proper stack frame on the stack
 118 when we perform it.  When we get here, however, we need to actually
 119 perform the call, so we treat it as an inline primop.
 120
 121 \begin{code}
 122 cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
 123   = primRetUnboxedTuple op args res_ty
 124
 125 -- tagToEnum# is special: we need to pull the constructor out of the table,
 126 -- and perform an appropriate return.
 127
 128 cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
 129   = ASSERT(isEnumerationTyCon tycon)
 130     getArgAmode arg `thenFC` \amode ->
 131         -- save the tag in a temporary in case amode overlaps
 132         -- with node.
 133     absC (CAssign dyn_tag amode)        `thenC`
 134     performReturn (
 135                 CAssign (CReg node)
 136                         (CVal (CIndex
 137                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 138                           dyn_tag PtrRep) PtrRep))
 139             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 140    where
 141         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 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         (Just (tycon,_)) = splitTyConApp_maybe res_ty
 151
 152
 153 cgExpr x@(StgCon (PrimOp op) args res_ty)
 154   | primOpOutOfLine op = tailCallPrimOp op args
 155   | otherwise
 156   = ASSERT(op /= SeqOp) -- can't handle SeqOp
 157
 158     getArgAmodes args   `thenFC` \ arg_amodes ->
 159
 160     case (getPrimOpResultInfo op) 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 alts)
 204   = cgCase expr live_vars save_vars bndr srt 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     -- ToDo: cost centre???
 237     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 238
 239         -- Save those variables right now!
 240     absC save_assts                             `thenC`
 241
 242         -- Produce code for the rhss
 243         -- and add suitable bindings to the environment
 244     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 245
 246         -- Do the body
 247     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 248 \end{code}
 249
 250
 251 %********************************************************
 252 %*                                                      *
 253 %*              SCC Expressions                         *
 254 %*                                                      *
 255 %********************************************************
 256
 257 SCC expressions are treated specially. They set the current cost
 258 centre.
 259 \begin{code}
 260 cgExpr (StgSCC cc expr)
 261   = ASSERT(sccAbleCostCentre cc)
 262     costCentresC
 263         SLIT("SET_CCC")
 264         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 265     `thenC`
 266     cgExpr expr
 267 \end{code}
 268
 269 ToDo: counting of dict sccs ...
 270
 271 %********************************************************
 272 %*                                                      *
 273 %*              Non-top-level bindings                  *
 274 %*                                                      *
 275 %********************************************************
 276 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 277
 278 We rely on the support code in @CgCon@ (to do constructors) and
 279 in @CgClosure@ (to do closures).
 280
 281 \begin{code}
 282 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 283         -- the Id is passed along so a binding can be set up
 284
 285 cgRhs name (StgRhsCon maybe_cc con args)
 286   = getArgAmodes args           `thenFC` \ amodes ->
 287     buildDynCon name maybe_cc con amodes (all zero_size args)
 288                                 `thenFC` \ idinfo ->
 289     returnFC (name, idinfo)
 290   where
 291     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 292
 293 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
 294   = mkRhsClosure name cc bi srt fvs upd_flag args body
 295 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
 296   = mkRhsClosure name cc bi srt fvs upd_flag args body
 297 \end{code}
 298
 299 mkRhsClosure looks for two special forms of the right-hand side:
 300         a) selector thunks.
 301         b) AP thunks
 302
 303 If neither happens, it just calls mkClosureLFInfo.  You might think
 304 that mkClosureLFInfo should do all this, but it seems wrong for the
 305 latter to look at the structure of an expression
 306
 307 Selectors
 308 ~~~~~~~~~
 309 We look at the body of the closure to see if it's a selector---turgid,
 310 but nothing deep.  We are looking for a closure of {\em exactly} the
 311 form:
 312
 313 ...  = [the_fv] \ u [] ->
 314          case the_fv of
 315            con a_1 ... a_n -> a_i
 316
 317
 318 \begin{code}
 319 mkRhsClosure    bndr cc bi srt
 320                 [the_fv]                -- Just one free var
 321                 upd_flag                -- Updatable thunk
 322                 []                      -- A thunk
 323                 body@(StgCase (StgApp scrutinee [{-no args-}])
 324                       _ _ _ _   -- ignore uniq, etc.
 325                       (StgAlgAlts case_ty
 326                          [(con, params, use_mask,
 327                             (StgApp selectee [{-no args-}]))]
 328                          StgNoDefault))
 329   |  the_fv == scrutinee                        -- Scrutinee is the only free variable
 330   && maybeToBool maybe_offset                   -- Selectee is a component of the tuple
 331   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 332   = ASSERT(is_single_constructor)
 333     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 334   where
 335     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 336                                 (isUpdatable upd_flag)
 337     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 338     maybe_offset          = assocMaybe params_w_offsets selectee
 339     Just the_offset       = maybe_offset
 340     offset_into_int       = the_offset - fixedHdrSize
 341     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 342     tycon                 = dataConTyCon con
 343 \end{code}
 344
 345
 346 Ap thunks
 347 ~~~~~~~~~
 348
 349 A more generic AP thunk of the form
 350
 351         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 352
 353 A set of these is compiled statically into the RTS, so we just use
 354 those.  We could extend the idea to thunks where some of the x_i are
 355 global ids (and hence not free variables), but this would entail
 356 generating a larger thunk.  It might be an option for non-optimising
 357 compilation, though.
 358
 359 We only generate an Ap thunk if all the free variables are pointers,
 360 for semi-obvious reasons.
 361
 362 \begin{code}
 363 mkRhsClosure    bndr cc bi srt
 364                 fvs
 365                 upd_flag
 366                 []                      -- No args; a thunk
 367                 body@(StgApp fun_id args)
 368
 369   | length args + 1 == arity
 370         && all isFollowableRep (map idPrimRep fvs)
 371         && isUpdatable upd_flag
 372         && arity <= mAX_SPEC_AP_SIZE
 373
 374                    -- Ha! an Ap thunk
 375         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 376
 377    where
 378         lf_info = mkApLFInfo (idType bndr) upd_flag arity
 379         -- the payload has to be in the correct order, hence we can't
 380         -- just use the fvs.
 381         payload    = StgVarArg fun_id : args
 382         arity      = length fvs
 383 \end{code}
 384
 385 The default case
 386 ~~~~~~~~~~~~~~~~
 387 \begin{code}
 388 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 389   = getSRTLabel         `thenFC` \ srt_label ->
 390     let lf_info =
 391           mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
 392     in
 393     cgRhsClosure bndr cc bi fvs args body lf_info
 394 \end{code}
 395
 396
 397 %********************************************************
 398 %*                                                      *
 399 %*              Let-no-escape bindings
 400 %*                                                      *
 401 %********************************************************
 402 \begin{code}
 403 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 404   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 405                         NonRecursive binder rhs
 406                                 `thenFC` \ (binder, info) ->
 407     addBindC binder info
 408
 409 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 410   = fixC (\ new_bindings ->
 411                 addBindsC new_bindings  `thenC`
 412                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 413                                 rhs_eob_info maybe_cc_slot Recursive b e
 414                         | (b,e) <- pairs ]
 415     ) `thenFC` \ new_bindings ->
 416
 417     addBindsC new_bindings
 418   where
 419     -- We add the binders to the live-in-rhss set so that we don't
 420     -- delete the bindings for the binder from the environment!
 421     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 422
 423 cgLetNoEscapeRhs
 424     :: StgLiveVars      -- Live in rhss
 425     -> EndOfBlockInfo
 426     -> Maybe VirtualSpOffset
 427     -> RecFlag
 428     -> Id
 429     -> StgRhs
 430     -> FCode (Id, CgIdInfo)
 431
 432 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 433                  (StgRhsClosure cc bi srt _ upd_flag args body)
 434   = -- We could check the update flag, but currently we don't switch it off
 435     -- for let-no-escaped things, so we omit the check too!
 436     -- case upd_flag of
 437     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 438     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 439     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
 440
 441 -- For a constructor RHS we want to generate a single chunk of code which
 442 -- can be jumped to from many places, which will return the constructor.
 443 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 444 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 445                  (StgRhsCon cc con args)
 446   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 447         []      --No args; the binder is data structure, not a function
 448         (StgCon (DataCon con) args (idType binder))
 449 \end{code}
 450
 451 Little helper for primitives that return unboxed tuples.
 452
 453
 454 \begin{code}
 455 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
 456 primRetUnboxedTuple op args res_ty
 457   = getArgAmodes args       `thenFC` \ arg_amodes ->
 458     {-
 459       put all the arguments in temporaries so they don't get stomped when
 460       we push the return address.
 461     -}
 462     let
 463       n_args              = length args
 464       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 465       arg_reps            = map getArgPrimRep args
 466       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 467     in
 468     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 469     {-
 470       allocate some temporaries for the return values.
 471     -}
 472     let
 473       (tc,ty_args)      = case splitTyConApp_maybe (repType res_ty) of
 474                             Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 475                             Just pr -> pr
 476       prim_reps          = map typePrimRep ty_args
 477       temp_uniqs         = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 478       temp_amodes        = zipWith CTemp temp_uniqs prim_reps
 479     in
 480     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 481
 482 \end{code}