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 module CgExpr ( cgExpr, getPrimOpArgAmodes ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Constants        ( mAX_SPEC_SELECTEE_SIZE )
  16 import StgSyn
  17 import CgMonad
  18 import AbsCSyn
  19
  20 import AbsCUtils        ( mkAbsCStmts, mkAbstractCs )
  21 import CgBindery        ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo )
  22 import CgCase           ( cgCase, saveVolatileVarsAndRegs )
  23 import CgClosure        ( cgRhsClosure )
  24 import CgCon            ( buildDynCon, cgReturnDataCon )
  25 import CgHeapery        ( allocHeap )
  26 import CgLetNoEscape    ( cgLetNoEscapeClosure )
  27 import CgRetConv        ( dataReturnConvAlg, ctrlReturnConvAlg,
  28                           DataReturnConvention(..), CtrlReturnConvention(..),
  29                           assignPrimOpResultRegs, makePrimOpArgsRobust
  30                         )
  31 import CgTailCall       ( cgTailCall, performReturn,
  32                           mkDynamicAlgReturnCode, mkPrimReturnCode
  33                         )
  34 import CLabel           ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
  35 import ClosureInfo      ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo,
  36                           layOutDynCon )
  37 import CostCentre       ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
  38 import HeapOffs         ( VirtualSpBOffset, intOffsetIntoGoods )
  39 import Id               ( dataConTyCon, idPrimRep, getIdArity,
  40                           mkIdSet, unionIdSets, GenId{-instance Outputable-},
  41                           Id
  42                         )
  43 import IdInfo           ( ArityInfo(..) )
  44 import Name             ( isLocallyDefined )
  45 import PrimOp           ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
  46                           getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
  47                         )
  48 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  49 import TyCon            ( tyConDataCons, maybeTyConSingleCon  )
  50 import Maybes           ( assocMaybe, maybeToBool )
  51 import Util             ( isIn )
  52 import Outputable
  53 \end{code}
  54
  55 This module provides the support code for @StgToAbstractC@ to deal
  56 with STG {\em expressions}.  See also @CgClosure@, which deals
  57 with closures, and @CgCon@, which deals with constructors.
  58
  59 \begin{code}
  60 cgExpr  :: StgExpr              -- input
  61         -> Code                 -- output
  62 \end{code}
  63
  64 %********************************************************
  65 %*                                                      *
  66 %*              Tail calls                              *
  67 %*                                                      *
  68 %********************************************************
  69
  70 ``Applications'' mean {\em tail calls}, a service provided by module
  71 @CgTailCall@.  This includes literals, which show up as
  72 @(STGApp (StgLitArg 42) [])@.
  73
  74 \begin{code}
  75 cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
  76 \end{code}
  77
  78 %********************************************************
  79 %*                                                      *
  80 %*              STG ConApps  (for inline versions)      *
  81 %*                                                      *
  82 %********************************************************
  83
  84 \begin{code}
  85 cgExpr (StgCon con args live_vars)
  86   = getArgAmodes args `thenFC` \ amodes ->
  87     cgReturnDataCon con amodes (all zero_size args) live_vars
  88   where
  89     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
  90 \end{code}
  91
  92 %********************************************************
  93 %*                                                      *
  94 %*              STG PrimApps  (unboxed primitive ops)   *
  95 %*                                                      *
  96 %********************************************************
  97
  98 Here is where we insert real live machine instructions.
  99
 100 \begin{code}
 101 cgExpr x@(StgPrim op args live_vars)
 102   = ASSERT(op /= SeqOp) -- can't handle SeqOp
 103     getPrimOpArgAmodes op args  `thenFC` \ arg_amodes ->
 104     let
 105         result_regs   = assignPrimOpResultRegs op
 106         result_amodes = map CReg result_regs
 107         may_gc  = primOpCanTriggerGC op
 108         dyn_tag = head result_amodes
 109             -- The tag from a primitive op returning an algebraic data type
 110             -- is returned in the first result_reg_amode
 111     in
 112     (if may_gc then
 113         -- Use registers for args, and assign args to the regs
 114         -- (Can-trigger-gc primops guarantee to have their args in regs)
 115         let
 116             (arg_robust_amodes, liveness_mask, arg_assts)
 117               = makePrimOpArgsRobust op arg_amodes
 118
 119             liveness_arg = mkIntCLit liveness_mask
 120         in
 121         returnFC (
 122             arg_assts,
 123             COpStmt result_amodes op
 124                     (pin_liveness op liveness_arg arg_robust_amodes)
 125                     liveness_mask
 126                     [{-no vol_regs-}]
 127         )
 128      else
 129         -- Use args from their current amodes.
 130         let
 131           liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
 132         in
 133         returnFC (
 134             COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
 135             AbsCNop
 136         )
 137     )                           `thenFC` \ (do_before_stack_cleanup,
 138                                              do_just_before_jump) ->
 139
 140     case (getPrimOpResultInfo op) of
 141
 142         ReturnsPrim kind ->
 143             performReturn do_before_stack_cleanup
 144                           (\ sequel -> robustifySequel may_gc sequel
 145                                                         `thenFC` \ (ret_asst, sequel') ->
 146                            absC (ret_asst `mkAbsCStmts` do_just_before_jump)
 147                                                         `thenC`
 148                            mkPrimReturnCode sequel')
 149                           live_vars
 150
 151         ReturnsAlg tycon ->
 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                   = case (ctrlReturnConvAlg tycon) of
 175                       VectoredReturn   _ -> vec_lbl
 176                       UnvectoredReturn _ -> dir_lbl
 177
 178                 vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
 179                                 dyn_tag DataPtrRep
 180
 181                 data_con = head (tyConDataCons tycon)
 182
 183                 (dir_lbl, num_of_fields)
 184                   = case (dataReturnConvAlg data_con) of
 185                       ReturnInRegs rs
 186                         -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
 187                             mkIntCLit (length rs)) -- for ticky-ticky only
 188
 189                       ReturnInHeap
 190                         -> pprPanic "CgExpr: can't return prim in heap:" (ppr data_con)
 191                           -- Never used, and no point in generating
 192                           -- the code for it!
 193   where
 194     -- for all PrimOps except ccalls, we pin the liveness info
 195     -- on as the first "argument"
 196     -- ToDo: un-duplicate?
 197
 198     pin_liveness (CCallOp _ _ _ _ _ _) _ args = args
 199     pin_liveness other_op liveness_arg args
 200       = liveness_arg :args
 201
 202     -- We only need to worry about the sequel when we may GC and the
 203     -- sequel is OnStack.  If that's the case, arrange to pull the
 204     -- sequel out into RetReg before performing the primOp.
 205
 206     robustifySequel True sequel@(OnStack _) =
 207         sequelToAmode sequel                    `thenFC` \ amode ->
 208         returnFC (CAssign (CReg RetReg) amode, InRetReg)
 209     robustifySequel _ sequel = returnFC (AbsCNop, sequel)
 210 \end{code}
 211
 212 %********************************************************
 213 %*                                                      *
 214 %*              Case expressions                        *
 215 %*                                                      *
 216 %********************************************************
 217 Case-expression conversion is complicated enough to have its own
 218 module, @CgCase@.
 219 \begin{code}
 220
 221 cgExpr (StgCase expr live_vars save_vars uniq alts)
 222   = cgCase expr live_vars save_vars uniq alts
 223 \end{code}
 224
 225
 226 %********************************************************
 227 %*                                                      *
 228 %*              Let and letrec                          *
 229 %*                                                      *
 230 %********************************************************
 231 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 232
 233 \begin{code}
 234 cgExpr (StgLet (StgNonRec name rhs) expr)
 235   = cgRhs name rhs      `thenFC` \ (name, info) ->
 236     addBindC name info  `thenC`
 237     cgExpr expr
 238
 239 cgExpr (StgLet (StgRec pairs) expr)
 240   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 241                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 242     ) `thenFC` \ new_bindings ->
 243
 244     addBindsC new_bindings `thenC`
 245     cgExpr expr
 246 \end{code}
 247
 248 \begin{code}
 249 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 250   =     -- Figure out what volatile variables to save
 251     nukeDeadBindings live_in_whole_let  `thenC`
 252     saveVolatileVarsAndRegs live_in_rhss
 253             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 254
 255         -- ToDo: cost centre???
 256
 257         -- Save those variables right now!
 258     absC save_assts                             `thenC`
 259
 260         -- Produce code for the rhss
 261         -- and add suitable bindings to the environment
 262     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 263
 264         -- Do the body
 265     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 266 \end{code}
 267
 268
 269 %********************************************************
 270 %*                                                      *
 271 %*              SCC Expressions                         *
 272 %*                                                      *
 273 %********************************************************
 274 \subsection[scc-codegen]{Converting StgSCC}
 275
 276 SCC expressions are treated specially. They set the current cost
 277 centre.
 278 \begin{code}
 279 cgExpr (StgSCC ty cc expr)
 280   = ASSERT(sccAbleCostCentre cc)
 281     costCentresC
 282         (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
 283         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 284     `thenC`
 285     cgExpr expr
 286 \end{code}
 287
 288 ToDo: counting of dict sccs ...
 289
 290 %********************************************************
 291 %*                                                      *
 292 %*              Non-top-level bindings                  *
 293 %*                                                      *
 294 %********************************************************
 295 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 296
 297 We rely on the support code in @CgCon@ (to do constructors) and
 298 in @CgClosure@ (to do closures).
 299
 300 \begin{code}
 301 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 302         -- the Id is passed along so a binding can be set up
 303
 304 cgRhs name (StgRhsCon maybe_cc con args)
 305   = getArgAmodes args           `thenFC` \ amodes ->
 306     buildDynCon name maybe_cc con amodes (all zero_size args)
 307                                 `thenFC` \ idinfo ->
 308     returnFC (name, idinfo)
 309   where
 310     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 311
 312 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
 313   = cgRhsClosure name cc bi fvs args body lf_info
 314   where
 315     lf_info = mkRhsLFInfo fvs upd_flag args body
 316
 317 \end{code}
 318
 319 mkRhsLFInfo looks for two special forms of the right-hand side:
 320         a) selector thunks.
 321         b) VAP thunks
 322
 323 If neither happens, it just calls mkClosureLFInfo.  You might think
 324 that mkClosureLFInfo should do all this, but
 325
 326         (a) it seems wrong for the latter to look at the structure
 327                 of an expression
 328
 329         [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here
 330          anyway because of (a).]
 331
 332         (b) mkRhsLFInfo has to be in the monad since it looks up in
 333                 the environment, and it's very tiresome for mkClosureLFInfo to
 334                 be.  Apart from anything else it would make a loop between
 335                 CgBindery and ClosureInfo.
 336
 337 Selectors
 338 ~~~~~~~~~
 339 We look at the body of the closure to see if it's a selector---turgid,
 340 but nothing deep.  We are looking for a closure of {\em exactly} the
 341 form:
 342 \begin{verbatim}
 343 ...  = [the_fv] \ u [] ->
 344          case the_fv of
 345            con a_1 ... a_n -> a_i
 346 \end{verbatim}
 347
 348 \begin{code}
 349 mkRhsLFInfo     [the_fv]                -- Just one free var
 350                 Updatable               -- Updatable thunk
 351                 []                      -- A thunk
 352                 (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
 353                       _ _ _   -- ignore live vars and uniq...
 354                       (StgAlgAlts case_ty
 355                          [(con, params, use_mask,
 356                             (StgApp (StgVarArg selectee) [{-no args-}] _))]
 357                          StgNoDefault))
 358   |  the_fv == scrutinee                        -- Scrutinee is the only free variable
 359   && maybeToBool maybe_offset                   -- Selectee is a component of the tuple
 360   && maybeToBool offset_into_int_maybe
 361   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 362   = -- ASSERT(is_single_constructor)            -- Should be true, but causes error for SpecTyCon
 363     mkSelectorLFInfo scrutinee con offset_into_int
 364   where
 365     (_, params_w_offsets) = layOutDynCon con idPrimRep params
 366     maybe_offset          = assocMaybe params_w_offsets selectee
 367     Just the_offset       = maybe_offset
 368     offset_into_int_maybe = intOffsetIntoGoods the_offset
 369     Just offset_into_int  = offset_into_int_maybe
 370     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
 371     tycon                 = dataConTyCon con
 372 \end{code}
 373
 374
 375 Vap thunks
 376 ~~~~~~~~~~
 377 Same kind of thing, looking for vector-apply thunks, of the form:
 378
 379         x = [...] \ .. [] -> f a1 .. an
 380
 381 where f has arity n.  We rely on the arity info inside the Id being correct.
 382
 383 \begin{code}
 384 mkRhsLFInfo     fvs
 385                 upd_flag
 386                 []                      -- No args; a thunk
 387                 (StgApp (StgVarArg fun_id) args _)
 388   | isLocallyDefined fun_id             -- Must be defined in this module
 389   =     -- Get the arity of the fun_id.  It's guaranteed to be correct (by setStgVarInfo).
 390      let
 391         arity_maybe = case getIdArity fun_id of
 392                         ArityExactly n  -> Just n
 393                         other           -> Nothing
 394      in
 395      case arity_maybe of
 396                 Just arity
 397                     | arity > 0 &&                      -- It'd better be a function!
 398                       arity == length args              -- Saturated application
 399                     ->          -- Ha!  A VAP thunk
 400                         mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
 401
 402                 other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
 403   where
 404         -- If the function is a free variable then it must be stored
 405         -- in the thunk too; if it isn't a free variable it must be
 406         -- because it's constant, so it doesn't need to be stored in the thunk
 407     store_fun_in_vap = fun_id `is_elem` fvs
 408     is_elem          = isIn "mkClosureLFInfo"
 409 \end{code}
 410
 411 The default case
 412 ~~~~~~~~~~~~~~~~
 413 \begin{code}
 414 mkRhsLFInfo fvs upd_flag args body
 415   = mkClosureLFInfo False{-not top level-} fvs upd_flag args
 416 \end{code}
 417
 418
 419 %********************************************************
 420 %*                                                      *
 421 %*              Let-no-escape bindings
 422 %*                                                      *
 423 %********************************************************
 424 \begin{code}
 425 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 426   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
 427                                 `thenFC` \ (binder, info) ->
 428     addBindC binder info
 429
 430 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 431   = fixC (\ new_bindings ->
 432                 addBindsC new_bindings  `thenC`
 433                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
 434                           maybe_cc_slot b e | (b,e) <- pairs ]
 435     ) `thenFC` \ new_bindings ->
 436
 437     addBindsC new_bindings
 438   where
 439     -- We add the binders to the live-in-rhss set so that we don't
 440     -- delete the bindings for the binder from the environment!
 441     full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
 442
 443 cgLetNoEscapeRhs
 444     :: StgLiveVars      -- Live in rhss
 445     -> EndOfBlockInfo
 446     -> Maybe VirtualSpBOffset
 447     -> Id
 448     -> StgRhs
 449     -> FCode (Id, CgIdInfo)
 450
 451 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 452                  (StgRhsClosure cc bi _ upd_flag args body)
 453   = -- We could check the update flag, but currently we don't switch it off
 454     -- for let-no-escaped things, so we omit the check too!
 455     -- case upd_flag of
 456     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 457     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 458     cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
 459
 460 -- For a constructor RHS we want to generate a single chunk of code which
 461 -- can be jumped to from many places, which will return the constructor.
 462 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 463 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 464                  (StgRhsCon cc con args)
 465   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
 466         []      --No args; the binder is data structure, not a function
 467         (StgCon con args full_live_in_rhss)
 468 \end{code}
 469
 470 Some PrimOps require a {\em fixed} amount of heap allocation.  Rather
 471 than tidy away ready for GC and do a full heap check, we simply
 472 allocate a completely uninitialised block in-line, just like any other
 473 thunk/constructor allocation, and pass it to the PrimOp as its first
 474 argument.  Remember! The PrimOp is entirely responsible for
 475 initialising the object.  In particular, the PrimOp had better not
 476 trigger GC before it has filled it in, and even then it had better
 477 make sure that the GC can find the object somehow.
 478
 479 Main current use: allocating SynchVars.
 480
 481 \begin{code}
 482 getPrimOpArgAmodes op args
 483   = getArgAmodes args           `thenFC` \ arg_amodes ->
 484
 485     case primOpHeapReq op of
 486         FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
 487                                   returnFC (amode : arg_amodes)
 488
 489         _                      -> returnFC arg_amodes
 490 \end{code}
 491
 492