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   = -- trace ("cgExpr:PrimApp:"++(ppShow 80 (ppr PprDebug x))) (
 102     getPrimOpArgAmodes op args                  `thenFC` \ arg_amodes ->
 103     let
 104         result_regs   = assignPrimOpResultRegs 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 op arg_amodes
 117
 118             liveness_arg = mkIntCLit liveness_mask
 119         in
 120         returnFC (
 121             arg_assts,
 122             mkAbstractCs [
 123               spat_prim_macro,
 124               COpStmt result_amodes op
 125                       (pin_liveness op liveness_arg arg_robust_amodes)
 126                       liveness_mask
 127                       [{-no vol_regs-}],
 128               spat_prim_stop_macro ]
 129         )
 130      else
 131         -- Use args from their current amodes.
 132         let
 133           liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
 134         in
 135         returnFC (
 136 --        DO NOT want CCallProfMacros in CSimultaneous stuff.  Yurgh.  (WDP 95/01)
 137 --              Arises in compiling PreludeGlaST (and elsewhere??)
 138 --        mkAbstractCs [
 139 --          spat_prim_macro,
 140             COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
 141 --          spat_prim_stop_macro ],
 142           AbsCNop
 143         )
 144     )                           `thenFC` \ (do_before_stack_cleanup,
 145                                              do_just_before_jump) ->
 146
 147     case (getPrimOpResultInfo op) of
 148
 149         ReturnsPrim kind ->
 150             performReturn do_before_stack_cleanup
 151                           (\ sequel -> robustifySequel may_gc sequel
 152                                                         `thenFC` \ (ret_asst, sequel') ->
 153                            absC (ret_asst `mkAbsCStmts` do_just_before_jump)
 154                                                         `thenC`
 155                            mkPrimReturnCode sequel')
 156                           live_vars
 157
 158         ReturnsAlg tycon ->
 159 --OLD:      evalCostCentreC "SET_RetCC" [CReg CurCostCentre]    `thenC`
 160             profCtrC SLIT("RET_NEW_IN_REGS") []                 `thenC`
 161
 162             performReturn do_before_stack_cleanup
 163                           (\ sequel -> robustifySequel may_gc sequel
 164                                                         `thenFC` \ (ret_asst, sequel') ->
 165                            absC (mkAbstractCs [ret_asst,
 166                                                do_just_before_jump,
 167                                                info_ptr_assign])
 168                         -- Must load info ptr here, not in do_just_before_stack_cleanup,
 169                         -- because the info-ptr reg clashes with argument registers
 170                         -- for the primop
 171                                                                 `thenC`
 172                                       mkDynamicAlgReturnCode tycon dyn_tag sequel')
 173                           live_vars
 174             where
 175
 176             -- Here, the destination _can_ be an update frame, so we need to make sure that
 177             -- infoptr (R2) is loaded with the constructor's info ptr.
 178
 179                 info_ptr_assign = CAssign (CReg infoptr) info_lbl
 180
 181                 info_lbl
 182                   = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) (
 183                     case (ctrlReturnConvAlg tycon) of
 184                       VectoredReturn _   -> vec_lbl
 185                       UnvectoredReturn _ -> dir_lbl
 186                     -- )
 187
 188                 vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind)
 189                                 dyn_tag DataPtrKind
 190
 191                 data_con = head (getTyConDataCons tycon)
 192                 dir_lbl  = case dataReturnConvAlg data_con of
 193                                 ReturnInRegs _ -> CLbl (mkPhantomInfoTableLabel data_con)
 194                                                        DataPtrKind
 195                                 ReturnInHeap   -> panic "CgExpr: can't return prim in heap"
 196                                           -- Never used, and no point in generating
 197                                           -- the code for it!
 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
 216     spat_prim_macro      = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]
 217     spat_prim_stop_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]
 218
 219 \end{code}
 220
 221 %********************************************************
 222 %*                                                      *
 223 %*              Case expressions                        *
 224 %*                                                      *
 225 %********************************************************
 226 Case-expression conversion is complicated enough to have its own
 227 module, @CgCase@.
 228 \begin{code}
 229
 230 cgExpr (StgCase expr live_vars save_vars uniq alts)
 231   = cgCase expr live_vars save_vars uniq alts
 232 \end{code}
 233
 234
 235 %********************************************************
 236 %*                                                      *
 237 %*              Let and letrec                          *
 238 %*                                                      *
 239 %********************************************************
 240 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 241
 242 \begin{code}
 243 cgExpr (StgLet (StgNonRec name rhs) expr)
 244   = cgRhs name rhs      `thenFC` \ (name, info) ->
 245     addBindC name info  `thenC`
 246     cgExpr expr
 247
 248 cgExpr (StgLet (StgRec pairs) expr)
 249   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 250                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 251     ) `thenFC` \ new_bindings ->
 252
 253     addBindsC new_bindings `thenC`
 254     cgExpr expr
 255 \end{code}
 256
 257 \begin{code}
 258 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 259   =     -- Figure out what volatile variables to save
 260     nukeDeadBindings live_in_whole_let  `thenC`
 261     saveVolatileVarsAndRegs live_in_rhss
 262             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 263
 264         -- ToDo: cost centre???
 265
 266         -- Save those variables right now!
 267     absC save_assts                             `thenC`
 268
 269         -- Produce code for the rhss
 270         -- and add suitable bindings to the environment
 271     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 272
 273         -- Do the body
 274     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 275 \end{code}
 276
 277
 278 %********************************************************
 279 %*                                                      *
 280 %*              SCC Expressions                         *
 281 %*                                                      *
 282 %********************************************************
 283 \subsection[scc-codegen]{Converting StgSCC}
 284
 285 SCC expressions are treated specially. They set the current cost
 286 centre.
 287
 288 For evaluation scoping we also need to save the cost centre in an
 289 ``restore CC frame''. We only need to do this once before setting all
 290 nested SCCs.
 291
 292 \begin{code}
 293 cgExpr scc_expr@(StgSCC ty cc expr)
 294 --OLD:WDP:94/06  = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr)
 295   = cgSccExpr scc_expr
 296 \end{code}
 297
 298 @cgSccExpr@ (also used in \tr{CgClosure}):
 299 We *don't* set the cost centre for CAF/Dict cost centres
 300 [Likewise Subsumed and NoCostCentre, but they probably
 301 don't exist in an StgSCC expression.]
 302 \begin{code}
 303 cgSccExpr (StgSCC ty cc expr)
 304   = (if setToAbleCostCentre cc then
 305         costCentresC SLIT("SET_CCC")
 306             [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)]
 307      else
 308         nopC)           `thenC`
 309     cgSccExpr expr
 310 cgSccExpr other
 311   = cgExpr other
 312 \end{code}
 313
 314 %********************************************************
 315 %*                                                      *
 316 %*              Non-top-level bindings                  *
 317 %*                                                      *
 318 %********************************************************
 319 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 320
 321 @cgBinding@ is only used for let/letrec, not for unboxed bindings.
 322 So the kind should always be @PtrKind@.
 323
 324 We rely on the support code in @CgCon@ (to do constructors) and
 325 in @CgClosure@ (to do closures).
 326
 327 \begin{code}
 328 cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
 329         -- the Id is passed along so a binding can be set up
 330
 331 cgRhs name (StgRhsCon maybe_cc con args)
 332   = getAtomAmodes args          `thenFC` \ amodes ->
 333     buildDynCon name maybe_cc con amodes (all zero_size args)
 334                                 `thenFC` \ idinfo ->
 335     returnFC (name, idinfo)
 336   where
 337     zero_size atom = getKindSize (getAtomKind atom) == 0
 338
 339 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
 340   = cgRhsClosure name cc bi fvs args body lf_info
 341   where
 342     lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
 343 \end{code}
 344
 345 \begin{code}
 346 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 347   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
 348                                 `thenFC` \ (binder, info) ->
 349     addBindC binder info
 350
 351 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 352   = fixC (\ new_bindings ->
 353                 addBindsC new_bindings  `thenC`
 354                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
 355                           maybe_cc_slot b e | (b,e) <- pairs ]
 356     ) `thenFC` \ new_bindings ->
 357
 358     addBindsC new_bindings
 359   where
 360     -- We add the binders to the live-in-rhss set so that we don't
 361     -- delete the bindings for the binder from the environment!
 362     full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
 363
 364 cgLetNoEscapeRhs
 365     :: PlainStgLiveVars -- Live in rhss
 366     -> EndOfBlockInfo
 367     -> Maybe VirtualSpBOffset
 368     -> Id
 369     -> PlainStgRhs
 370     -> FCode (Id, CgIdInfo)
 371
 372 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 373                  (StgRhsClosure cc bi _ upd_flag args body)
 374   = -- We could check the update flag, but currently we don't switch it off
 375     -- for let-no-escaped things, so we omit the check too!
 376     -- case upd_flag of
 377     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 378     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 379     cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
 380
 381 -- For a constructor RHS we want to generate a single chunk of code which
 382 -- can be jumped to from many places, which will return the constructor.
 383 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 384 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 385                  (StgRhsCon cc con args)
 386   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
 387         []      --No args; the binder is data structure, not a function
 388         (StgConApp con args full_live_in_rhss)
 389 \end{code}
 390
 391 Some PrimOps require a {\em fixed} amount of heap allocation.  Rather
 392 than tidy away ready for GC and do a full heap check, we simply
 393 allocate a completely uninitialised block in-line, just like any other
 394 thunk/constructor allocation, and pass it to the PrimOp as its first
 395 argument.  Remember! The PrimOp is entirely responsible for
 396 initialising the object.  In particular, the PrimOp had better not
 397 trigger GC before it has filled it in, and even then it had better
 398 make sure that the GC can find the object somehow.
 399
 400 Main current use: allocating SynchVars.
 401
 402 \begin{code}
 403 getPrimOpArgAmodes op args
 404   = getAtomAmodes args          `thenFC` \ arg_amodes ->
 405
 406     case primOpHeapReq op of
 407
 408         FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
 409                                   returnFC (amode : arg_amodes)
 410
 411         _                      -> returnFC arg_amodes
 412 \end{code}
 413
 414