ghc/compiler/codeGen/CgExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgExpr.lhs,v 1.50 2002/08/02 13:08:34 simonmar Exp $
   5 %
   6 %********************************************************
   7 %*                                                      *
   8 \section[CgExpr]{Converting @StgExpr@s}
   9 %*                                                      *
  10 %********************************************************
  11
  12 \begin{code}
  13 module CgExpr ( cgExpr ) where
  14
  15 #include "HsVersions.h"
  16
  17 import Constants        ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
  18 import StgSyn
  19 import CgMonad
  20 import AbsCSyn
  21 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  22 import CLabel           ( mkClosureTblLabel )
  23
  24 import SMRep            ( fixedHdrSize )
  25 import CgBindery        ( getArgAmodes, getArgAmode, CgIdInfo,
  26                           nukeDeadBindings, addBindC, addBindsC )
  27 import CgCase           ( cgCase, saveVolatileVarsAndRegs,
  28                           restoreCurrentCostCentre )
  29 import CgClosure        ( cgRhsClosure, cgStdRhsClosure )
  30 import CgCon            ( buildDynCon, cgReturnDataCon )
  31 import CgLetNoEscape    ( cgLetNoEscapeClosure )
  32 import CgRetConv        ( dataReturnConvPrim )
  33 import CgTailCall       ( cgTailCall, performReturn, performPrimReturn,
  34                           mkDynamicAlgReturnCode, mkPrimReturnCode,
  35                           tailCallPrimOp, returnUnboxedTuple
  36                         )
  37 import ClosureInfo      ( mkClosureLFInfo, mkSelectorLFInfo,
  38                           mkApLFInfo, layOutDynConstr )
  39 import CostCentre       ( sccAbleCostCentre, isSccCountCostCentre )
  40 import Id               ( idPrimRep, idType, Id )
  41 import VarSet
  42 import PrimOp           ( primOpOutOfLine, getPrimOpResultInfo,
  43                           PrimOp(..), PrimOpResultInfo(..) )
  44 import TysPrim          ( foreignObjPrimTyCon, arrayPrimTyCon,
  45                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
  46                           mutableArrayPrimTyCon )
  47 import PrimRep          ( PrimRep(..), isFollowableRep )
  48 import TyCon            ( isUnboxedTupleTyCon, isEnumerationTyCon )
  49 import Type             ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
  50 import Maybes           ( maybeToBool )
  51 import ListSetOps       ( assocMaybe )
  52 import Unique           ( mkBuiltinUnique )
  53 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  54 import Util             ( lengthIs )
  55 import Outputable
  56 \end{code}
  57
  58 This module provides the support code for @StgToAbstractC@ to deal
  59 with STG {\em expressions}.  See also @CgClosure@, which deals
  60 with closures, and @CgCon@, which deals with constructors.
  61
  62 \begin{code}
  63 cgExpr  :: StgExpr              -- input
  64         -> Code                 -- output
  65 \end{code}
  66
  67 %********************************************************
  68 %*                                                      *
  69 %*              Tail calls                              *
  70 %*                                                      *
  71 %********************************************************
  72
  73 ``Applications'' mean {\em tail calls}, a service provided by module
  74 @CgTailCall@.  This includes literals, which show up as
  75 @(STGApp (StgLitArg 42) [])@.
  76
  77 \begin{code}
  78 cgExpr (StgApp fun args) = cgTailCall fun args
  79 \end{code}
  80
  81 %********************************************************
  82 %*                                                      *
  83 %*              STG ConApps  (for inline versions)      *
  84 %*                                                      *
  85 %********************************************************
  86
  87 \begin{code}
  88 cgExpr (StgConApp con args)
  89   = getArgAmodes args `thenFC` \ amodes ->
  90     cgReturnDataCon con amodes
  91 \end{code}
  92
  93 Literals are similar to constructors; they return by putting
  94 themselves in an appropriate register and returning to the address on
  95 top of the stack.
  96
  97 \begin{code}
  98 cgExpr (StgLit lit)
  99   = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
 100 \end{code}
 101
 102
 103 %********************************************************
 104 %*                                                      *
 105 %*              STG PrimApps  (unboxed primitive ops)   *
 106 %*                                                      *
 107 %********************************************************
 108
 109 Here is where we insert real live machine instructions.
 110
 111 NOTE about _ccall_GC_:
 112
 113 A _ccall_GC_ is treated as an out-of-line primop (returns True
 114 for primOpOutOfLine) so that when we see the call in case context
 115         case (ccall ...) of { ... }
 116 we get a proper stack frame on the stack when we perform it.  When we
 117 get in a tail-call position, however, we need to actually perform the
 118 call, so we treat it as an inline primop.
 119
 120 \begin{code}
 121 cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
 122   = primRetUnboxedTuple op args res_ty
 123
 124 -- tagToEnum# is special: we need to pull the constructor out of the table,
 125 -- and perform an appropriate return.
 126
 127 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 128   = ASSERT(isEnumerationTyCon tycon)
 129     getArgAmode arg `thenFC` \amode ->
 130         -- save the tag in a temporary in case amode overlaps
 131         -- with node.
 132     absC (CAssign dyn_tag amode)        `thenC`
 133     performReturn (
 134                 CAssign (CReg node)
 135                         (CVal (CIndex
 136                           (CLbl (mkClosureTblLabel tycon) PtrRep)
 137                           dyn_tag PtrRep) PtrRep))
 138             (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
 139    where
 140         dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 141           --
 142           -- if you're reading this code in the attempt to figure
 143           -- out why the compiler panic'ed here, it is probably because
 144           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
 145           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
 146           --
 147           -- That won't work.
 148           --
 149         tycon = tyConAppTyCon res_ty
 150
 151
 152 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 153   | primOpOutOfLine primop
 154   = tailCallPrimOp primop args
 155
 156   | otherwise
 157   = getArgAmodes args   `thenFC` \ arg_amodes ->
 158
 159     case (getPrimOpResultInfo primop) of
 160
 161         ReturnsPrim kind ->
 162             let result_amode = CReg (dataReturnConvPrim kind) in
 163             performReturn
 164               (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
 165               (mkPrimReturnCode (text "primapp)" <+> ppr x))
 166
 167         -- otherwise, must be returning an enumerated type (eg. Bool).
 168         -- we've only got the tag in R2, so we have to load the constructor
 169         -- itself into R1.
 170
 171         ReturnsAlg tycon
 172             | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
 173
 174             | isEnumerationTyCon  tycon ->
 175                 performReturn
 176                      (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
 177                           (\ sequel ->
 178                           absC (CAssign (CReg node) closure_lbl) `thenC`
 179                           mkDynamicAlgReturnCode tycon dyn_tag sequel)
 180
 181             where
 182                -- Pull a unique out of thin air to put the tag in.
 183                -- It shouldn't matter if this overlaps with anything - we're
 184                -- about to return anyway.
 185                dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
 186
 187                closure_lbl = CVal (CIndex
 188                                (CLbl (mkClosureTblLabel tycon) PtrRep)
 189                                dyn_tag PtrRep) PtrRep
 190
 191 \end{code}
 192
 193 %********************************************************
 194 %*                                                      *
 195 %*              Case expressions                        *
 196 %*                                                      *
 197 %********************************************************
 198 Case-expression conversion is complicated enough to have its own
 199 module, @CgCase@.
 200 \begin{code}
 201
 202 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 203   = cgCase expr live_vars save_vars bndr srt alts
 204 \end{code}
 205
 206
 207 %********************************************************
 208 %*                                                      *
 209 %*              Let and letrec                          *
 210 %*                                                      *
 211 %********************************************************
 212 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 213
 214 \begin{code}
 215 cgExpr (StgLet (StgNonRec srt name rhs) expr)
 216   = cgRhs srt name rhs  `thenFC` \ (name, info) ->
 217     addBindC name info  `thenC`
 218     cgExpr expr
 219
 220 cgExpr (StgLet (StgRec srt pairs) expr)
 221   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
 222                             listFCs [ cgRhs srt b e | (b,e) <- pairs ]
 223     ) `thenFC` \ new_bindings ->
 224
 225     addBindsC new_bindings `thenC`
 226     cgExpr expr
 227 \end{code}
 228
 229 \begin{code}
 230 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 231   =     -- Figure out what volatile variables to save
 232     nukeDeadBindings live_in_whole_let  `thenC`
 233     saveVolatileVarsAndRegs live_in_rhss
 234             `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
 235     -- ToDo: cost centre???
 236     restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
 237
 238         -- Save those variables right now!
 239     absC save_assts                             `thenC`
 240
 241         -- Produce code for the rhss
 242         -- and add suitable bindings to the environment
 243     cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
 244
 245         -- Do the body
 246     setEndOfBlockInfo rhs_eob_info (cgExpr body)
 247 \end{code}
 248
 249
 250 %********************************************************
 251 %*                                                      *
 252 %*              SCC Expressions                         *
 253 %*                                                      *
 254 %********************************************************
 255
 256 SCC expressions are treated specially. They set the current cost
 257 centre.
 258 \begin{code}
 259 cgExpr (StgSCC cc expr)
 260   = ASSERT(sccAbleCostCentre cc)
 261     costCentresC
 262         FSLIT("SET_CCC")
 263         [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
 264     `thenC`
 265     cgExpr expr
 266 \end{code}
 267
 268 ToDo: counting of dict sccs ...
 269
 270 %********************************************************
 271 %*                                                      *
 272 %*              Non-top-level bindings                  *
 273 %*                                                      *
 274 %********************************************************
 275 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
 276
 277 We rely on the support code in @CgCon@ (to do constructors) and
 278 in @CgClosure@ (to do closures).
 279
 280 \begin{code}
 281 cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
 282         -- the Id is passed along so a binding can be set up
 283
 284 cgRhs srt name (StgRhsCon maybe_cc con args)
 285   = getArgAmodes args                           `thenFC` \ amodes ->
 286     buildDynCon name maybe_cc con amodes        `thenFC` \ idinfo ->
 287     returnFC (name, idinfo)
 288
 289 cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
 290   = mkRhsClosure name cc bi srt fvs upd_flag args body
 291 \end{code}
 292
 293 mkRhsClosure looks for two special forms of the right-hand side:
 294         a) selector thunks.
 295         b) AP thunks
 296
 297 If neither happens, it just calls mkClosureLFInfo.  You might think
 298 that mkClosureLFInfo should do all this, but it seems wrong for the
 299 latter to look at the structure of an expression
 300
 301 Selectors
 302 ~~~~~~~~~
 303 We look at the body of the closure to see if it's a selector---turgid,
 304 but nothing deep.  We are looking for a closure of {\em exactly} the
 305 form:
 306
 307 ...  = [the_fv] \ u [] ->
 308          case the_fv of
 309            con a_1 ... a_n -> a_i
 310
 311
 312 \begin{code}
 313 mkRhsClosure    bndr cc bi srt
 314                 [the_fv]                -- Just one free var
 315                 upd_flag                -- Updatable thunk
 316                 []                      -- A thunk
 317                 body@(StgCase (StgApp scrutinee [{-no args-}])
 318                       _ _ _ _   -- ignore uniq, etc.
 319                       (StgAlgAlts (Just tycon)
 320                          [(con, params, use_mask,
 321                             (StgApp selectee [{-no args-}]))]
 322                          StgNoDefault))
 323   |  the_fv == scrutinee                -- Scrutinee is the only free variable
 324   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
 325   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE  -- Offset is small enough
 326   = -- NOT TRUE: ASSERT(is_single_constructor)
 327     -- The simplifier may have statically determined that the single alternative
 328     -- is the only possible case and eliminated the others, even if there are
 329     -- other constructors in the datatype.  It's still ok to make a selector
 330     -- thunk in this case, because we *know* which constructor the scrutinee
 331     -- will evaluate to.
 332     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
 333   where
 334     lf_info               = mkSelectorLFInfo (idType bndr) offset_into_int
 335                                                 (isUpdatable upd_flag)
 336     (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
 337                                 -- Just want the layout
 338     maybe_offset          = assocMaybe params_w_offsets selectee
 339     Just the_offset       = maybe_offset
 340     offset_into_int       = the_offset - fixedHdrSize
 341     bogus_name            = panic "mkRhsClosure"
 342 \end{code}
 343
 344 Ap thunks
 345 ~~~~~~~~~
 346
 347 A more generic AP thunk of the form
 348
 349         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
 350
 351 A set of these is compiled statically into the RTS, so we just use
 352 those.  We could extend the idea to thunks where some of the x_i are
 353 global ids (and hence not free variables), but this would entail
 354 generating a larger thunk.  It might be an option for non-optimising
 355 compilation, though.
 356
 357 We only generate an Ap thunk if all the free variables are pointers,
 358 for semi-obvious reasons.
 359
 360 \begin{code}
 361 mkRhsClosure    bndr cc bi srt
 362                 fvs
 363                 upd_flag
 364                 []                      -- No args; a thunk
 365                 body@(StgApp fun_id args)
 366
 367   | args `lengthIs` (arity-1)
 368         && all isFollowableRep (map idPrimRep fvs)
 369         && isUpdatable upd_flag
 370         && arity <= mAX_SPEC_AP_SIZE
 371
 372                    -- Ha! an Ap thunk
 373         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
 374
 375    where
 376         lf_info = mkApLFInfo (idType bndr) upd_flag arity
 377         -- the payload has to be in the correct order, hence we can't
 378         -- just use the fvs.
 379         payload    = StgVarArg fun_id : args
 380         arity      = length fvs
 381 \end{code}
 382
 383 The default case
 384 ~~~~~~~~~~~~~~~~
 385 \begin{code}
 386 mkRhsClosure bndr cc bi srt fvs upd_flag args body
 387   = cgRhsClosure bndr cc bi srt fvs args body lf_info
 388   where
 389     lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 390 \end{code}
 391
 392
 393 %********************************************************
 394 %*                                                      *
 395 %*              Let-no-escape bindings
 396 %*                                                      *
 397 %********************************************************
 398 \begin{code}
 399 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 400         (StgNonRec srt binder rhs)
 401   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
 402                         NonRecursive srt binder rhs
 403                                 `thenFC` \ (binder, info) ->
 404     addBindC binder info
 405
 406 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
 407         (StgRec srt pairs)
 408   = fixC (\ new_bindings ->
 409                 addBindsC new_bindings  `thenC`
 410                 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
 411                                 rhs_eob_info maybe_cc_slot Recursive srt b e
 412                         | (b,e) <- pairs ]
 413     ) `thenFC` \ new_bindings ->
 414
 415     addBindsC new_bindings
 416   where
 417     -- We add the binders to the live-in-rhss set so that we don't
 418     -- delete the bindings for the binder from the environment!
 419     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
 420
 421 cgLetNoEscapeRhs
 422     :: StgLiveVars      -- Live in rhss
 423     -> EndOfBlockInfo
 424     -> Maybe VirtualSpOffset
 425     -> RecFlag
 426     -> SRT
 427     -> Id
 428     -> StgRhs
 429     -> FCode (Id, CgIdInfo)
 430
 431 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 432                  (StgRhsClosure cc bi _ upd_flag args body)
 433   = -- We could check the update flag, but currently we don't switch it off
 434     -- for let-no-escaped things, so we omit the check too!
 435     -- case upd_flag of
 436     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
 437     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
 438     cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
 439         maybe_cc_slot rec args body
 440
 441 -- For a constructor RHS we want to generate a single chunk of code which
 442 -- can be jumped to from many places, which will return the constructor.
 443 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 444 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
 445                  (StgRhsCon cc con args)
 446   = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
 447                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 448         []      --No args; the binder is data structure, not a function
 449         (StgConApp con args)
 450 \end{code}
 451
 452 Little helper for primitives that return unboxed tuples.
 453
 454
 455 \begin{code}
 456 primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 457 primRetUnboxedTuple op args res_ty
 458   = getArgAmodes args       `thenFC` \ arg_amodes1 ->
 459     {-
 460       For a foreign call, we might need to fiddle with some of the args:
 461       for example, when passing a ByteArray#, we pass a ptr to the goods
 462       rather than the heap object.
 463     -}
 464     let
 465         arg_amodes
 466           | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
 467           | otherwise          = arg_amodes1
 468     in
 469     {-
 470       put all the arguments in temporaries so they don't get stomped when
 471       we push the return address.
 472     -}
 473     let
 474       n_args              = length args
 475       arg_uniqs           = map mkBuiltinUnique [0 .. n_args-1]
 476       arg_reps            = map getAmodeRep arg_amodes
 477       arg_temps           = zipWith CTemp arg_uniqs arg_reps
 478     in
 479     absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
 480     {-
 481       allocate some temporaries for the return values.
 482     -}
 483     let
 484       ty_args     = tyConAppArgs (repType res_ty)
 485       prim_reps   = map typePrimRep ty_args
 486       temp_uniqs  = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
 487       temp_amodes = zipWith CTemp temp_uniqs prim_reps
 488     in
 489     returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
 490
 491 shimFCallArg arg amode
 492   | tycon == foreignObjPrimTyCon
 493         = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
 494   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 495         = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
 496   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 497         = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
 498   | otherwise = amode
 499   where
 500         -- should be a tycon app, since this is a foreign call
 501         tycon = tyConAppTyCon (repType (stgArgType arg))
 502 \end{code}