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