ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.35 2000/07/11 16:03:37 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 )
  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 PrimOp           ( primOpOutOfLine, ccallMayGC,
  44                           getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
  45                         )
  46 import PrimRep          ( getPrimRepSize, PrimRep(..), isFollowableRep )
  47 import TyCon            ( maybeTyConSingleCon,
  48                           isUnboxedTupleTyCon, isEnumerationTyCon )
  49 import Type             ( Type, typePrimRep, splitTyConApp_maybe, repType )
  50 import Maybes           ( assocMaybe, maybeToBool )
  51 import Unique           ( mkBuiltinUnique )
  52 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  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 (StgPrimApp op@(CCallOp ccall) 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 (StgPrimApp 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           --
 140           -- if you're reading this code in the attempt to figure
 141           -- out why the compiler panic'ed here, it is probably because
 142           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 143           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 144           --
 145           -- That won't work.
 146           --
 147         (Just (tycon,_)) = splitTyConApp_maybe res_ty
 148
 149
 150 cgExpr x@(StgPrimApp op args res_ty)
 151   | primOpOutOfLine op = tailCallPrimOp op args
 152   | otherwise
 153   = ASSERT(op /= SeqOp) -- can't handle SeqOp
 154
 155     getArgAmodes args   `thenFC` \ arg_amodes ->
 156
 157     case (getPrimOpResultInfo op) of
 158
 159         ReturnsPrim kind ->
 160             let result_amode = CReg (dataReturnConvPrim kind) in
 161             performReturn
 162               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 163               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 164
 165         -- otherwise, must be returning an enumerated type (eg. Bool).
 166         -- we've only got the tag in R2, so we have to load the constructor
 167         -- itself into R1.
 168
 169         ReturnsAlg tycon
 170             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 171
 172             | isEnumerationTyCon  tycon ->
 173                 performReturn
 174                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 175                           (\ sequel ->
 176                           absC (CAssign (CReg node) closure_lbl) `thenC`
 177                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 178
 179             where
 180                -- Pull a unique out of thin air to put the tag in.
 181                -- It shouldn't matter if this overlaps with anything - we're
 182                -- about to return anyway.
 183                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 184
 185                closure_lbl = CVal (CIndex
 186                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 187                                dyn_tag PtrRep) PtrRep
 188
 189 \end{code}
 190
 191 %********************************************************
 192 %*                                                      *
 193 %*              Case expressions                        *
 194 %*                                                      *
 195 %********************************************************
 196 Case-expression conversion is complicated enough to have its own
 197 module, @CgCase@.
 198 \begin{code}
 199
 200 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 201   = cgCase expr live_vars save_vars bndr srt alts
 202 \end{code}
 203
 204
 205 %********************************************************
 206 %*                                                      *
 207 %*              Let and letrec                          *
 208 %*                                                      *
 209 %********************************************************
 210 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 211
 212 \begin{code}
 213 cgExpr (StgLet (StgNonRec name rhs) expr)
 214   = cgRhs name rhs      `thenFC` \ (name, info) ->
 215     addBindC name info  `thenC`
 216     cgExpr expr
 217
 218 cgExpr (StgLet (StgRec pairs) expr)
 219   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 220                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 221     ) `thenFC` \ new_bindings ->
 222
 223     addBindsC new_bindings `thenC`
 224     cgExpr expr
 225 \end{code}
 226
 227 \begin{code}
 228 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 229   =     -- Figure out what volatile variables to save
 230     nukeDeadBindings live_in_whole_let  `thenC`
 231     saveVolatileVarsAndRegs live_in_rhss
 232             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 233     -- ToDo: cost centre???
 234     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 235
 236         -- Save those variables right now!
 237     absC save_assts                             `thenC`
 238
 239         -- Produce code for the rhss
 240         -- and add suitable bindings to the environment
 241     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 242
 243         -- Do the body
 244     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 245 \end{code}
 246
 247
 248 %********************************************************
 249 %*                                                      *
 250 %*              SCC Expressions                         *
 251 %*                                                      *
 252 %********************************************************
 253
 254 SCC expressions are treated specially. They set the current cost
 255 centre.
 256 \begin{code}
 257 cgExpr (StgSCC cc expr)
 258   = ASSERT(sccAbleCostCentre cc)
 259     costCentresC
 260         SLIT("SET_CCC")
 261         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 262     `thenC`
 263     cgExpr expr
 264 \end{code}
 265
 266 ToDo: counting of dict sccs ...
 267
 268 %********************************************************
 269 %*                                                      *
 270 %*              Non-top-level bindings                  *
 271 %*                                                      *
 272 %********************************************************
 273 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 274
 275 We rely on the support code in @CgCon@ (to do constructors) and
 276 in @CgClosure@ (to do closures).
 277
 278 \begin{code}
 279 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 280         -- the Id is passed along so a binding can be set up
 281
 282 cgRhs name (StgRhsCon maybe_cc con args)
 283   = getArgAmodes args                           `thenFC` \ amodes ->
 284     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 285     returnFC (name, idinfo)
 286
 287 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
 288   = mkRhsClosure name cc bi srt fvs upd_flag args body
 289 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
 290   = mkRhsClosure name cc bi srt fvs upd_flag args body
 291 \end{code}
 292
 293 mkRhsClosure looks for two special forms of the right-hand side:
 294         a) selector thunks.
 295         b) AP thunks
 296
 297 If neither happens, it just calls mkClosureLFInfo.  You might think
 298 that mkClosureLFInfo should do all this, but it seems wrong for the
 299 latter to look at the structure of an expression
 300
 301 Selectors
 302 ~~~~~~~~~
 303 We look at the body of the closure to see if it's a selector---turgid,
 304 but nothing deep.  We are looking for a closure of {\em exactly} the
 305 form:
 306
 307 ...  = [the_fv] \ u [] ->
 308          case the_fv of
 309            con a_1 ... a_n -> a_i
 310
 311
 312 \begin{code}
 313 mkRhsClosure    bndr cc bi srt
 314                 [the_fv]                -- Just one free var
 315                 upd_flag                -- Updatable thunk
 316                 []                      -- A thunk
 317                 body@(StgCase (StgApp scrutinee [{-no args-}])
 318                       _ _ _ _   -- ignore uniq, etc.
 319                       (StgAlgAlts case_ty
 320                          [(con, params, use_mask,
 321                             (StgApp selectee [{-no args-}]))]
 322                          StgNoDefault))
 323   |  the_fv == scrutinee                        -- Scrutinee is the only free variable
 324   && maybeToBool maybe_offset                   -- Selectee is a component of the tuple
 325   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 326   = ASSERT(is_single_constructor)
 327     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 328   where
 329     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 330                                 (isUpdatable upd_flag)
 331     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 332     maybe_offset          = assocMaybe params_w_offsets selectee
 333     Just the_offset       = maybe_offset
 334     offset_into_int       = the_offset - fixedHdrSize
 335     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 336     tycon                 = dataConTyCon con
 337 \end{code}
 338
 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   | length args + 1 == arity
 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   = getSRTLabel         `thenFC` \ srt_label ->
 384     let lf_info =
 385           mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
 386     in
 387     cgRhsClosure bndr cc bi fvs args body lf_info
 388 \end{code}
 389
 390
 391 %********************************************************
 392 %*                                                      *
 393 %*              Let-no-escape bindings
 394 %*                                                      *
 395 %********************************************************
 396 \begin{code}
 397 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 398   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 399                         NonRecursive binder rhs
 400                                 `thenFC` \ (binder, info) ->
 401     addBindC binder info
 402
 403 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec 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 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     -> Id
 423     -> StgRhs
 424     -> FCode (Id, CgIdInfo)
 425
 426 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 427                  (StgRhsClosure cc bi srt _ upd_flag args body)
 428   = -- We could check the update flag, but currently we don't switch it off
 429     -- for let-no-escaped things, so we omit the check too!
 430     -- case upd_flag of
 431     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 432     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 433     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
 434
 435 -- For a constructor RHS we want to generate a single chunk of code which
 436 -- can be jumped to from many places, which will return the constructor.
 437 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 438 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 439                  (StgRhsCon cc con args)
 440   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 441         []      --No args; the binder is data structure, not a function
 442         (StgConApp con args)
 443 \end{code}
 444
 445 Little helper for primitives that return unboxed tuples.
 446
 447
 448 \begin{code}
 449 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
 450 primRetUnboxedTuple op args res_ty
 451   = getArgAmodes args       `thenFC` \ arg_amodes ->
 452     {-
 453       put all the arguments in temporaries so they don't get stomped when
 454       we push the return address.
 455     -}
 456     let
 457       n_args              = length args
 458       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 459       arg_reps            = map getArgPrimRep args
 460       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 461     in
 462     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 463     {-
 464       allocate some temporaries for the return values.
 465     -}
 466     let
 467       (tc,ty_args)      = case splitTyConApp_maybe (repType res_ty) of
 468                             Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 469                             Just pr -> pr
 470       prim_reps          = map typePrimRep ty_args
 471       temp_uniqs         = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 472       temp_amodes        = zipWith CTemp temp_uniqs prim_reps
 473     in
 474     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 475 \end{code}