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