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