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