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 StgSyn
  19 import CgMonad
  20 import AbsCSyn
  21
  22 import AbsCUtils        ( mkAbsCStmts, mkAbstractCs )
  23 import CgBindery        ( getArgAmodes )
  24 import CgCase           ( cgCase, saveVolatileVarsAndRegs )
  25 import CgClosure        ( cgRhsClosure )
  26 import CgCon            ( buildDynCon, cgReturnDataCon )
  27 import CgHeapery        ( allocHeap )
  28 import CgLetNoEscape    ( cgLetNoEscapeClosure )
  29 import CgRetConv        ( dataReturnConvAlg, ctrlReturnConvAlg,
  30                           DataReturnConvention(..), CtrlReturnConvention(..),
  31                           assignPrimOpResultRegs, makePrimOpArgsRobust
  32                         )
  33 import CgTailCall       ( cgTailCall, performReturn,
  34                           mkDynamicAlgReturnCode, mkPrimReturnCode
  35                         )
  36 import CLabel           ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
  37 import ClosureInfo      ( mkClosureLFInfo )
  38 import CostCentre       ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
  39 import HeapOffs         ( SYN_IE(VirtualSpBOffset) )
  40 import Id               ( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
  41 import PprStyle         ( PprStyle(..) )
  42 import PrimOp           ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
  43                           getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
  44                         )
  45 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  46 import TyCon            ( tyConDataCons )
  47 import Util             ( panic, pprPanic, assertPanic )
  48 \end{code}
  49
  50 This module provides the support code for @StgToAbstractC@ to deal
  51 with STG {\em expressions}.  See also @CgClosure@, which deals
  52 with closures, and @CgCon@, which deals with constructors.
  53
  54 \begin{code}
  55 cgExpr  :: StgExpr              -- input
  56         -> Code                 -- output
  57 \end{code}
  58
  59 %********************************************************
  60 %*                                                      *
  61 %*              Tail calls                              *
  62 %*                                                      *
  63 %********************************************************
  64
  65 ``Applications'' mean {\em tail calls}, a service provided by module
  66 @CgTailCall@.  This includes literals, which show up as
  67 @(STGApp (StgLitArg 42) [])@.
  68
  69 \begin{code}
  70 cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
  71 \end{code}
  72
  73 %********************************************************
  74 %*                                                      *
  75 %*              STG ConApps  (for inline versions)      *
  76 %*                                                      *
  77 %********************************************************
  78
  79 \begin{code}
  80 cgExpr (StgCon con args live_vars)
  81   = getArgAmodes args `thenFC` \ amodes ->
  82     cgReturnDataCon con amodes (all zero_size args) live_vars
  83   where
  84     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
  85 \end{code}
  86
  87 %********************************************************
  88 %*                                                      *
  89 %*              STG PrimApps  (unboxed primitive ops)   *
  90 %*                                                      *
  91 %********************************************************
  92
  93 Here is where we insert real live machine instructions.
  94
  95 \begin{code}
  96 cgExpr x@(StgPrim op args live_vars)
  97   = ASSERT(op /= SeqOp) -- can't handle SeqOp
  98     getPrimOpArgAmodes op args  `thenFC` \ arg_amodes ->
  99     let
 100         result_regs   = assignPrimOpResultRegs op
 101         result_amodes = map CReg result_regs
 102         may_gc  = primOpCanTriggerGC op
 103         dyn_tag = head result_amodes
 104             -- The tag from a primitive op returning an algebraic data type
 105             -- is returned in the first result_reg_amode
 106     in
 107     (if may_gc then
 108         -- Use registers for args, and assign args to the regs
 109         -- (Can-trigger-gc primops guarantee to have their args in regs)
 110         let
 111             (arg_robust_amodes, liveness_mask, arg_assts)
 112               = makePrimOpArgsRobust op arg_amodes
 113
 114             liveness_arg = mkIntCLit liveness_mask
 115         in
 116         returnFC (
 117             arg_assts,
 118             COpStmt result_amodes op
 119                     (pin_liveness op liveness_arg arg_robust_amodes)
 120                     liveness_mask
 121                     [{-no vol_regs-}]
 122         )
 123      else
 124         -- Use args from their current amodes.
 125         let
 126           liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
 127         in
 128         returnFC (
 129             COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
 130             AbsCNop
 131         )
 132     )                           `thenFC` \ (do_before_stack_cleanup,
 133                                              do_just_before_jump) ->
 134
 135     case (getPrimOpResultInfo op) of
 136
 137         ReturnsPrim kind ->
 138             performReturn do_before_stack_cleanup
 139                           (\ sequel -> robustifySequel may_gc sequel
 140                                                         `thenFC` \ (ret_asst, sequel') ->
 141                            absC (ret_asst `mkAbsCStmts` do_just_before_jump)
 142                                                         `thenC`
 143                            mkPrimReturnCode sequel')
 144                           live_vars
 145
 146         ReturnsAlg tycon ->
 147             profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields]    `thenC`
 148
 149             performReturn do_before_stack_cleanup
 150                           (\ sequel -> robustifySequel may_gc sequel
 151                                                         `thenFC` \ (ret_asst, sequel') ->
 152                            absC (mkAbstractCs [ret_asst,
 153                                                do_just_before_jump,
 154                                                info_ptr_assign])
 155                         -- Must load info ptr here, not in do_just_before_stack_cleanup,
 156                         -- because the info-ptr reg clashes with argument registers
 157                         -- for the primop
 158                                                                 `thenC`
 159                                       mkDynamicAlgReturnCode tycon dyn_tag sequel')
 160                           live_vars
 161             where
 162
 163             -- Here, the destination _can_ be an update frame, so we need to make sure that
 164             -- infoptr (R2) is loaded with the constructor's info ptr.
 165
 166                 info_ptr_assign = CAssign (CReg infoptr) info_lbl
 167
 168                 info_lbl
 169                   = case (ctrlReturnConvAlg tycon) of
 170                       VectoredReturn   _ -> vec_lbl
 171                       UnvectoredReturn _ -> dir_lbl
 172
 173                 vec_lbl  = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
 174                                 dyn_tag DataPtrRep
 175
 176                 data_con = head (tyConDataCons tycon)
 177
 178                 (dir_lbl, num_of_fields)
 179                   = case (dataReturnConvAlg data_con) of
 180                       ReturnInRegs rs
 181                         -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
 182                             mkIntCLit (length rs)) -- for ticky-ticky only
 183
 184                       ReturnInHeap
 185                         -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
 186                           -- Never used, and no point in generating
 187                           -- the code for it!
 188   where
 189     -- for all PrimOps except ccalls, we pin the liveness info
 190     -- on as the first "argument"
 191     -- ToDo: un-duplicate?
 192
 193     pin_liveness (CCallOp _ _ _ _ _) _ args = args
 194     pin_liveness other_op liveness_arg args
 195       = liveness_arg :args
 196
 197     -- We only need to worry about the sequel when we may GC and the
 198     -- sequel is OnStack.  If that's the case, arrange to pull the
 199     -- sequel out into RetReg before performing the primOp.
 200
 201     robustifySequel True sequel@(OnStack _) =
 202         sequelToAmode sequel                    `thenFC` \ amode ->
 203         returnFC (CAssign (CReg RetReg) amode, InRetReg)
 204     robustifySequel _ sequel = returnFC (AbsCNop, sequel)
 205 \end{code}
 206
 207 %********************************************************
 208 %*                                                      *
 209 %*              Case expressions                        *
 210 %*                                                      *
 211 %********************************************************
 212 Case-expression conversion is complicated enough to have its own
 213 module, @CgCase@.
 214 \begin{code}
 215
 216 cgExpr (StgCase expr live_vars save_vars uniq alts)
 217   = cgCase expr live_vars save_vars uniq alts
 218 \end{code}
 219
 220
 221 %********************************************************
 222 %*                                                      *
 223 %*              Let and letrec                          *
 224 %*                                                      *
 225 %********************************************************
 226 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 227
 228 \begin{code}
 229 cgExpr (StgLet (StgNonRec name rhs) expr)
 230   = cgRhs name rhs      `thenFC` \ (name, info) ->
 231     addBindC name info  `thenC`
 232     cgExpr expr
 233
 234 cgExpr (StgLet (StgRec pairs) expr)
 235   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 236                             listFCs [ cgRhs b e | (b,e) <- pairs ]
 237     ) `thenFC` \ new_bindings ->
 238
 239     addBindsC new_bindings `thenC`
 240     cgExpr expr
 241 \end{code}
 242
 243 \begin{code}
 244 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 245   =     -- Figure out what volatile variables to save
 246     nukeDeadBindings live_in_whole_let  `thenC`
 247     saveVolatileVarsAndRegs live_in_rhss
 248             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 249
 250         -- ToDo: cost centre???
 251
 252         -- Save those variables right now!
 253     absC save_assts                             `thenC`
 254
 255         -- Produce code for the rhss
 256         -- and add suitable bindings to the environment
 257     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 258
 259         -- Do the body
 260     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 261 \end{code}
 262
 263
 264 %********************************************************
 265 %*                                                      *
 266 %*              SCC Expressions                         *
 267 %*                                                      *
 268 %********************************************************
 269 \subsection[scc-codegen]{Converting StgSCC}
 270
 271 SCC expressions are treated specially. They set the current cost
 272 centre.
 273 \begin{code}
 274 cgExpr (StgSCC ty cc expr)
 275   = ASSERT(sccAbleCostCentre cc)
 276     costCentresC
 277         (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
 278         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 279     `thenC`
 280     cgExpr expr
 281 \end{code}
 282
 283 ToDo: counting of dict sccs ...
 284
 285 %********************************************************
 286 %*                                                      *
 287 %*              Non-top-level bindings                  *
 288 %*                                                      *
 289 %********************************************************
 290 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 291
 292 @cgBinding@ is only used for let/letrec, not for unboxed bindings.
 293 So the kind should always be @PtrRep@.
 294
 295 We rely on the support code in @CgCon@ (to do constructors) and
 296 in @CgClosure@ (to do closures).
 297
 298 \begin{code}
 299 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 300         -- the Id is passed along so a binding can be set up
 301
 302 cgRhs name (StgRhsCon maybe_cc con args)
 303   = getArgAmodes args           `thenFC` \ amodes ->
 304     buildDynCon name maybe_cc con amodes (all zero_size args)
 305                                 `thenFC` \ idinfo ->
 306     returnFC (name, idinfo)
 307   where
 308     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 309
 310 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
 311   = cgRhsClosure name cc bi fvs args body lf_info
 312   where
 313     lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
 314 \end{code}
 315
 316 \begin{code}
 317 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
 318   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
 319                                 `thenFC` \ (binder, info) ->
 320     addBindC binder info
 321
 322 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
 323   = fixC (\ new_bindings ->
 324                 addBindsC new_bindings  `thenC`
 325                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
 326                           maybe_cc_slot b e | (b,e) <- pairs ]
 327     ) `thenFC` \ new_bindings ->
 328
 329     addBindsC new_bindings
 330   where
 331     -- We add the binders to the live-in-rhss set so that we don't
 332     -- delete the bindings for the binder from the environment!
 333     full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
 334
 335 cgLetNoEscapeRhs
 336     :: StgLiveVars      -- Live in rhss
 337     -> EndOfBlockInfo
 338     -> Maybe VirtualSpBOffset
 339     -> Id
 340     -> StgRhs
 341     -> FCode (Id, CgIdInfo)
 342
 343 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 344                  (StgRhsClosure cc bi _ upd_flag args body)
 345   = -- We could check the update flag, but currently we don't switch it off
 346     -- for let-no-escaped things, so we omit the check too!
 347     -- case upd_flag of
 348     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 349     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 350     cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
 351
 352 -- For a constructor RHS we want to generate a single chunk of code which
 353 -- can be jumped to from many places, which will return the constructor.
 354 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 355 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
 356                  (StgRhsCon cc con args)
 357   = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
 358         []      --No args; the binder is data structure, not a function
 359         (StgCon con args full_live_in_rhss)
 360 \end{code}
 361
 362 Some PrimOps require a {\em fixed} amount of heap allocation.  Rather
 363 than tidy away ready for GC and do a full heap check, we simply
 364 allocate a completely uninitialised block in-line, just like any other
 365 thunk/constructor allocation, and pass it to the PrimOp as its first
 366 argument.  Remember! The PrimOp is entirely responsible for
 367 initialising the object.  In particular, the PrimOp had better not
 368 trigger GC before it has filled it in, and even then it had better
 369 make sure that the GC can find the object somehow.
 370
 371 Main current use: allocating SynchVars.
 372
 373 \begin{code}
 374 getPrimOpArgAmodes op args
 375   = getArgAmodes args           `thenFC` \ arg_amodes ->
 376
 377     case primOpHeapReq op of
 378         FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
 379                                   returnFC (amode : arg_amodes)
 380
 381         _                      -> returnFC arg_amodes
 382 \end{code}
 383
 384