ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 %********************************************************
   5 %*                                                      *
   6 \section[CgExpr]{Converting @StgExpr@s}
   7 %*                                                      *
   8 %********************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module CgExpr (
  14         cgExpr, cgSccExpr, getPrimOpArgAmodes
  15
  16         -- and to make the interface self-sufficient...
  17     ) where
  18
  19 import StgSyn
  20 import CgMonad
  21 import AbsCSyn
  22
  23 import PrelInfo         ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
  24                           primOpHeapReq, getPrimOpResultInfo, PrimRep,
  25                           primOpCanTriggerGC
  26                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  27                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  28                         )
  29 import Type             ( isPrimType, getTyConDataCons )
  30 import CLabel   ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
  31 import ClosureInfo      ( LambdaFormInfo, mkClosureLFInfo )
  32 import CgBindery        ( getAtomAmodes )
  33 import CgCase           ( cgCase, saveVolatileVarsAndRegs )
  34 import CgClosure        ( cgRhsClosure )
  35 import CgCon            ( buildDynCon, cgReturnDataCon )
  36 import CgHeapery        ( allocHeap )
  37 import CgLetNoEscape    ( cgLetNoEscapeClosure )
  38 import CgRetConv        -- various things...
  39 import CgTailCall       ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
  40                           mkPrimReturnCode
  41                         )
  42 import CostCentre       ( setToAbleCostCentre, isDupdCC, CostCentre )
  43 import Maybes           ( Maybe(..) )
  44 import PrimRep          ( getPrimRepSize )
  45 import UniqSet
  46 import Util
  47 \end{code}
  48
  49 This module provides the support code for @StgToAbstractC@ to deal
  50 with STG {\em expressions}.  See also @CgClosure@, which deals
  51 with closures, and @CgCon@, which deals with constructors.
  52
  53 \begin{code}
  54 cgExpr  :: StgExpr              -- input
  55         -> Code                 -- output
  56 \end{code}
  57
  58 %********************************************************
  59 %*                                                      *
  60 %*              Tail calls                              *
  61 %*                                                      *
  62 %********************************************************
  63
  64 ``Applications'' mean {\em tail calls}, a service provided by module
  65 @CgTailCall@.  This includes literals, which show up as
  66 @(STGApp (StgLitArg 42) [])@.
  67
  68 \begin{code}
  69 cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
  70 \end{code}
  71
  72 %********************************************************
  73 %*                                                      *
  74 %*              STG ConApps  (for inline versions)      *
  75 %*                                                      *
  76 %********************************************************
  77
  78 \begin{code}
  79 cgExpr (StgCon con args live_vars)
  80   = getAtomAmodes args `thenFC` \ amodes ->
  81     cgReturnDataCon con amodes (all zero_size args) live_vars
  82   where
  83     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
  84 \end{code}
  85
  86 %********************************************************
  87 %*                                                      *
  88 %*              STG PrimApps  (unboxed primitive ops)   *
  89 %*                                                      *
  90 %********************************************************
  91
  92 Here is where we insert real live machine instructions.
  93
  94 \begin{code}
  95 cgExpr x@(StgPrim op args live_vars)
  96   = getIntSwitchChkrC           `thenFC` \ isw_chkr ->
  97     getPrimOpArgAmodes op args  `thenFC` \ arg_amodes ->
  98     let
  99         result_regs   = assignPrimOpResultRegs {-NO:isw_chkr-} op
 100         result_amodes = map CReg result_regs
 101         may_gc  = primOpCanTriggerGC op
 102         dyn_tag = head result_amodes
 103             -- The tag from a primitive op returning an algebraic data type
 104             -- is returned in the first result_reg_amode
 105     in
 106     (if may_gc then
 107         -- Use registers for args, and assign args to the regs
 108         -- (Can-trigger-gc primops guarantee to have their args in regs)
 109         let
 110             (arg_robust_amodes, liveness_mask, arg_assts)
 111               = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
 112
 113             liveness_arg = mkIntCLit liveness_mask
 114         in
 115         returnFC (
 116             arg_assts,
 117             COpStmt result_amodes op
 118                     (pin_liveness op liveness_arg arg_robust_amodes)
 119                     liveness_mask
 120                     [{-no vol_regs-}]
 121         )
 122      else
 123         -- Use args from their current amodes.
 124         let
 125           liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
 126         in
 127         returnFC (
 128             COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
 129             AbsCNop
 130         )
 131     )                           `thenFC` \ (do_before_stack_cleanup,
 132                                              do_just_before_jump) ->
 133
 134     case (getPrimOpResultInfo op) of
 135
 136         ReturnsPrim kind ->
 137             performReturn do_before_stack_cleanup
 138                           (\ sequel -> robustifySequel may_gc sequel
 139                                                         `thenFC` \ (ret_asst, sequel') ->
 140                            absC (ret_asst `mkAbsCStmts` do_just_before_jump)
 141                                                         `thenC`
 142                            mkPrimReturnCode sequel')
 143                           live_vars
 144
 145         ReturnsAlg tycon ->
 146             profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields]    `thenC`
 147
 148             performReturn do_before_stack_cleanup
 149                           (\ sequel -> robustifySequel may_gc sequel
 150                                                         `thenFC` \ (ret_asst, sequel') ->
 151                            absC (mkAbstractCs [ret_asst,
 152                                                do_just_before_jump,
 153                                                info_ptr_assign])
 154                         -- Must load info ptr here, not in do_just_before_stack_cleanup,
 155                         -- because the info-ptr reg clashes with argument registers
 156                         -- for the primop
 157                                                                 `thenC`
 158                                       mkDynamicAlgReturnCode tycon dyn_tag sequel')
 159                           live_vars
 160             where
 161
 162             -- Here, the destination _can_ be an update frame, so we need to make sure that
 163             -- infoptr (R2) is loaded with the constructor's info ptr.
 164
 165                 info_ptr_assign = CAssign (CReg infoptr) info_lbl
 166
 167                 info_lbl
 168                   = case (ctrlReturnConvAlg tycon) of
 169                       VectoredReturn   _ -> vec_lbl
 170                       UnvectoredReturn _ -> dir_lbl
 171
 172                 vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
 173                                 dyn_tag DataPtrRep
 174
 175                 data_con = head (getTyConDataCons tycon)
 176
 177                 (dir_lbl, num_of_fields)
 178                   = case (dataReturnConvAlg fake_isw_chkr data_con) of
 179                       ReturnInRegs rs
 180                         -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
 181                             mkIntCLit (length rs)) -- for ticky-ticky only
 182
 183                       ReturnInHeap
 184                         -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
 185                           -- Never used, and no point in generating
 186                           -- the code for it!
 187
 188                 fake_isw_chkr x = Nothing
 189   where
 190     -- for all PrimOps except ccalls, we pin the liveness info
 191     -- on as the first "argument"
 192     -- ToDo: un-duplicate?
 193
 194     pin_liveness (CCallOp _ _ _ _ _) _ args = args
 195     pin_liveness other_op liveness_arg args
 196       = liveness_arg :args
 197
 198     -- We only need to worry about the sequel when we may GC and the
 199     -- sequel is OnStack.  If that's the case, arrange to pull the
 200     -- sequel out into RetReg before performing the primOp.
 201
 202     robustifySequel True sequel@(OnStack _) =
 203         sequelToAmode sequel                    `thenFC` \ amode ->
 204         returnFC (CAssign (CReg RetReg) amode, InRetReg)
 205     robustifySequel _ sequel = returnFC (AbsCNop, sequel)
 206 \end{code}
 207
 208 %********************************************************
 209 %*                                                      *
 210 %*              Case expressions                        *
 211 %*                                                      *
 212 %********************************************************
 213 Case-expression conversion is complicated enough to have its own
 214 module, @CgCase@.
 215 \begin{code}
 216
 217 cgExpr (StgCase expr live_vars save_vars uniq alts)
 218   = cgCase expr live_vars save_vars uniq alts
 219 \end{code}
 220
 221
 222 %********************************************************
 223 %*                                                      *
 224 %*              Let and letrec                          *
 225 %*                                                      *
 226 %********************************************************
 227 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 228
 229 \begin{code}
 230 cgExpr (StgLet (StgNonRec name rhs) expr)
 231   = cgRhs name rhs      `thenFC` \ (name, info) ->
 232     addBindC name info  `thenC`
 233     cgExpr expr
 234
 235 cgExpr (StgLet (StgRec pairs) expr)
 236   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 237                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 238     ) `thenFC` \ new_bindings ->
 239
 240     addBindsC new_bindings `thenC`
 241     cgExpr expr
 242 \end{code}
 243
 244 \begin{code}
 245 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 246   =     -- Figure out what volatile variables to save
 247     nukeDeadBindings live_in_whole_let  `thenC`
 248     saveVolatileVarsAndRegs live_in_rhss
 249             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 250
 251         -- ToDo: cost centre???
 252
 253         -- Save those variables right now!
 254     absC save_assts                             `thenC`
 255
 256         -- Produce code for the rhss
 257         -- and add suitable bindings to the environment
 258     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 259
 260         -- Do the body
 261     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 262 \end{code}
 263
 264
 265 %********************************************************
 266 %*                                                      *
 267 %*              SCC Expressions                         *
 268 %*                                                      *
 269 %********************************************************
 270 \subsection[scc-codegen]{Converting StgSCC}
 271
 272 SCC expressions are treated specially. They set the current cost
 273 centre.
 274
 275 For evaluation scoping we also need to save the cost centre in an
 276 ``restore CC frame''. We only need to do this once before setting all
 277 nested SCCs.
 278
 279 \begin{code}
 280 cgExpr scc_expr@(StgSCC ty cc expr) = cgSccExpr scc_expr
 281 \end{code}
 282
 283 @cgSccExpr@ (also used in \tr{CgClosure}):
 284 We *don't* set the cost centre for CAF/Dict cost centres
 285 [Likewise Subsumed and NoCostCentre, but they probably
 286 don't exist in an StgSCC expression.]
 287 \begin{code}
 288 cgSccExpr (StgSCC ty cc expr)
 289   = (if setToAbleCostCentre cc then
 290         costCentresC SLIT("SET_CCC")
 291             [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)]
 292      else
 293         nopC)           `thenC`
 294     cgSccExpr expr
 295 cgSccExpr other
 296   = cgExpr other
 297 \end{code}
 298
 299 %********************************************************
 300 %*                                                      *
 301 %*              Non-top-level bindings                  *
 302 %*                                                      *
 303 %********************************************************
 304 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 305
 306 @cgBinding@ is only used for let/letrec, not for unboxed bindings.
 307 So the kind should always be @PtrRep@.
 308
 309 We rely on the support code in @CgCon@ (to do constructors) and
 310 in @CgClosure@ (to do closures).
 311
 312 \begin{code}
 313 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 314         -- the Id is passed along so a binding can be set up
 315
 316 cgRhs name (StgRhsCon maybe_cc con args)
 317   = getAtomAmodes args          `thenFC` \ amodes ->
 318     buildDynCon name maybe_cc con amodes (all zero_size args)
 319                                 `thenFC` \ idinfo ->
 320     returnFC (name, idinfo)
 321   where
 322     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 323
 324 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
 325   = cgRhsClosure name cc bi fvs args body lf_info
 326   where
 327     lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
 328 \end{code}
 329
 330 \begin{code}
 331 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 332   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
 333                                 `thenFC` \ (binder, info) ->
 334     addBindC binder info
 335
 336 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 337   = fixC (\ new_bindings ->
 338                 addBindsC new_bindings  `thenC`
 339                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
 340                           maybe_cc_slot b e | (b,e) <- pairs ]
 341     ) `thenFC` \ new_bindings ->
 342
 343     addBindsC new_bindings
 344   where
 345     -- We add the binders to the live-in-rhss set so that we don't
 346     -- delete the bindings for the binder from the environment!
 347     full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
 348
 349 cgLetNoEscapeRhs
 350     :: StgLiveVars      -- Live in rhss
 351     -> EndOfBlockInfo
 352     -> Maybe VirtualSpBOffset
 353     -> Id
 354     -> StgRhs
 355     -> FCode (Id, CgIdInfo)
 356
 357 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 358                  (StgRhsClosure cc bi _ upd_flag args body)
 359   = -- We could check the update flag, but currently we don't switch it off
 360     -- for let-no-escaped things, so we omit the check too!
 361     -- case upd_flag of
 362     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 363     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 364     cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
 365
 366 -- For a constructor RHS we want to generate a single chunk of code which
 367 -- can be jumped to from many places, which will return the constructor.
 368 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 369 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 370                  (StgRhsCon cc con args)
 371   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
 372         []      --No args; the binder is data structure, not a function
 373         (StgCon con args full_live_in_rhss)
 374 \end{code}
 375
 376 Some PrimOps require a {\em fixed} amount of heap allocation.  Rather
 377 than tidy away ready for GC and do a full heap check, we simply
 378 allocate a completely uninitialised block in-line, just like any other
 379 thunk/constructor allocation, and pass it to the PrimOp as its first
 380 argument.  Remember! The PrimOp is entirely responsible for
 381 initialising the object.  In particular, the PrimOp had better not
 382 trigger GC before it has filled it in, and even then it had better
 383 make sure that the GC can find the object somehow.
 384
 385 Main current use: allocating SynchVars.
 386
 387 \begin{code}
 388 getPrimOpArgAmodes op args
 389   = getAtomAmodes args          `thenFC` \ arg_amodes ->
 390
 391     case primOpHeapReq op of
 392
 393         FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
 394                                   returnFC (amode : arg_amodes)
 395
 396         _                      -> returnFC arg_amodes
 397 \end{code}
 398
 399