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