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