2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.30 1999/10/25 13:21:16 sof Exp $
6 %********************************************************
8 \section[CgExpr]{Converting @StgExpr@s}
10 %********************************************************
13 module CgExpr ( cgExpr ) where
15 #include "HsVersions.h"
17 import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
21 import AbsCUtils ( mkAbstractCs )
22 import CLabel ( mkClosureTblLabel )
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
37 import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
38 mkApLFInfo, layOutDynCon )
39 import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
40 import Id ( idPrimRep, idType, Id )
42 import DataCon ( DataCon, dataConTyCon )
43 import Const ( Con(..) )
44 import IdInfo ( ArityInfo(..) )
45 import PrimOp ( primOpOutOfLine,
46 getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
48 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
49 import TyCon ( maybeTyConSingleCon,
50 isUnboxedTupleTyCon, isEnumerationTyCon )
51 import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
52 import Maybes ( assocMaybe, maybeToBool )
53 import Unique ( mkBuiltinUnique )
54 import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
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.
63 cgExpr :: StgExpr -- input
67 %********************************************************
71 %********************************************************
73 ``Applications'' mean {\em tail calls}, a service provided by module
74 @CgTailCall@. This includes literals, which show up as
75 @(STGApp (StgLitArg 42) [])@.
78 cgExpr (StgApp fun args) = cgTailCall fun args
81 %********************************************************
83 %* STG ConApps (for inline versions) *
85 %********************************************************
88 cgExpr (StgCon (DataCon con) args res_ty)
89 = getArgAmodes args `thenFC` \ amodes ->
90 cgReturnDataCon con amodes (all zero_size args)
92 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
95 Literals are similar to constructors; they return by putting
96 themselves in an appropriate register and returning to the address on
100 cgExpr (StgCon (Literal lit) args res_ty)
101 = ASSERT( null args )
102 performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
106 %********************************************************
108 %* STG PrimApps (unboxed primitive ops) *
110 %********************************************************
112 Here is where we insert real live machine instructions.
114 NOTE about _ccall_GC_:
116 A _ccall_GC_ is treated as an out-of-line primop for the case
117 expression code, because we want a proper stack frame on the stack
118 when we perform it. When we get here, however, we need to actually
119 perform the call, so we treat it as an inline primop.
122 cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
123 = primRetUnboxedTuple op args res_ty
125 -- tagToEnum# is special: we need to pull the constructor out of the table,
126 -- and perform an appropriate return.
128 cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
129 = ASSERT(isEnumerationTyCon tycon)
130 getArgAmode arg `thenFC` \amode ->
131 -- save the tag in a temporary in case amode overlaps
133 absC (CAssign dyn_tag amode) `thenC`
137 (CLbl (mkClosureTblLabel tycon) PtrRep)
138 dyn_tag PtrRep) PtrRep))
139 (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
141 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
143 -- if you're reading this code in the attempt to figure
144 -- out why the compiler panic'ed here, it is probably because
145 -- you used tagToEnum# in a non-monomorphic setting, e.g.,
146 -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
150 (Just (tycon,_)) = splitTyConApp_maybe res_ty
153 cgExpr x@(StgCon (PrimOp op) args res_ty)
154 | primOpOutOfLine op = tailCallPrimOp op args
156 = ASSERT(op /= SeqOp) -- can't handle SeqOp
158 getArgAmodes args `thenFC` \ arg_amodes ->
160 case (getPrimOpResultInfo op) of
163 let result_amode = CReg (dataReturnConvPrim kind) in
165 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
166 (mkPrimReturnCode (text "primapp)" <+> ppr x))
168 -- otherwise, must be returning an enumerated type (eg. Bool).
169 -- we've only got the tag in R2, so we have to load the constructor
173 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
175 | isEnumerationTyCon tycon ->
177 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
179 absC (CAssign (CReg node) closure_lbl) `thenC`
180 mkDynamicAlgReturnCode tycon dyn_tag sequel)
183 -- Pull a unique out of thin air to put the tag in.
184 -- It shouldn't matter if this overlaps with anything - we're
185 -- about to return anyway.
186 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
188 closure_lbl = CVal (CIndex
189 (CLbl (mkClosureTblLabel tycon) PtrRep)
190 dyn_tag PtrRep) PtrRep
194 %********************************************************
196 %* Case expressions *
198 %********************************************************
199 Case-expression conversion is complicated enough to have its own
203 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
204 = cgCase expr live_vars save_vars bndr srt alts
208 %********************************************************
212 %********************************************************
213 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
216 cgExpr (StgLet (StgNonRec name rhs) expr)
217 = cgRhs name rhs `thenFC` \ (name, info) ->
218 addBindC name info `thenC`
221 cgExpr (StgLet (StgRec pairs) expr)
222 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
223 listFCs [ cgRhs b e | (b,e) <- pairs ]
224 ) `thenFC` \ new_bindings ->
226 addBindsC new_bindings `thenC`
231 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
232 = -- Figure out what volatile variables to save
233 nukeDeadBindings live_in_whole_let `thenC`
234 saveVolatileVarsAndRegs live_in_rhss
235 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
236 -- ToDo: cost centre???
237 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
239 -- Save those variables right now!
240 absC save_assts `thenC`
242 -- Produce code for the rhss
243 -- and add suitable bindings to the environment
244 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
247 setEndOfBlockInfo rhs_eob_info (cgExpr body)
251 %********************************************************
255 %********************************************************
257 SCC expressions are treated specially. They set the current cost
260 cgExpr (StgSCC cc expr)
261 = ASSERT(sccAbleCostCentre cc)
264 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
269 ToDo: counting of dict sccs ...
271 %********************************************************
273 %* Non-top-level bindings *
275 %********************************************************
276 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
278 We rely on the support code in @CgCon@ (to do constructors) and
279 in @CgClosure@ (to do closures).
282 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
283 -- the Id is passed along so a binding can be set up
285 cgRhs name (StgRhsCon maybe_cc con args)
286 = getArgAmodes args `thenFC` \ amodes ->
287 buildDynCon name maybe_cc con amodes (all zero_size args)
289 returnFC (name, idinfo)
291 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
293 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
294 = mkRhsClosure name cc bi srt fvs upd_flag args body
295 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
296 = mkRhsClosure name cc bi srt fvs upd_flag args body
299 mkRhsClosure looks for two special forms of the right-hand side:
303 If neither happens, it just calls mkClosureLFInfo. You might think
304 that mkClosureLFInfo should do all this, but it seems wrong for the
305 latter to look at the structure of an expression
309 We look at the body of the closure to see if it's a selector---turgid,
310 but nothing deep. We are looking for a closure of {\em exactly} the
313 ... = [the_fv] \ u [] ->
315 con a_1 ... a_n -> a_i
319 mkRhsClosure bndr cc bi srt
320 [the_fv] -- Just one free var
321 upd_flag -- Updatable thunk
323 body@(StgCase (StgApp scrutinee [{-no args-}])
324 _ _ _ _ -- ignore uniq, etc.
326 [(con, params, use_mask,
327 (StgApp selectee [{-no args-}]))]
329 | the_fv == scrutinee -- Scrutinee is the only free variable
330 && maybeToBool maybe_offset -- Selectee is a component of the tuple
331 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
332 = ASSERT(is_single_constructor)
333 cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
335 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
336 (isUpdatable upd_flag)
337 (_, params_w_offsets) = layOutDynCon con idPrimRep params
338 maybe_offset = assocMaybe params_w_offsets selectee
339 Just the_offset = maybe_offset
340 offset_into_int = the_offset - fixedHdrSize
341 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
342 tycon = dataConTyCon con
349 A more generic AP thunk of the form
351 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
353 A set of these is compiled statically into the RTS, so we just use
354 those. We could extend the idea to thunks where some of the x_i are
355 global ids (and hence not free variables), but this would entail
356 generating a larger thunk. It might be an option for non-optimising
359 We only generate an Ap thunk if all the free variables are pointers,
360 for semi-obvious reasons.
363 mkRhsClosure bndr cc bi srt
366 [] -- No args; a thunk
367 body@(StgApp fun_id args)
369 | length args + 1 == arity
370 && all isFollowableRep (map idPrimRep fvs)
371 && isUpdatable upd_flag
372 && arity <= mAX_SPEC_AP_SIZE
375 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
378 lf_info = mkApLFInfo (idType bndr) upd_flag arity
379 -- the payload has to be in the correct order, hence we can't
381 payload = StgVarArg fun_id : args
388 mkRhsClosure bndr cc bi srt fvs upd_flag args body
389 = getSRTLabel `thenFC` \ srt_label ->
391 mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
393 cgRhsClosure bndr cc bi fvs args body lf_info
397 %********************************************************
399 %* Let-no-escape bindings
401 %********************************************************
403 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
404 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
405 NonRecursive binder rhs
406 `thenFC` \ (binder, info) ->
409 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
410 = fixC (\ new_bindings ->
411 addBindsC new_bindings `thenC`
412 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
413 rhs_eob_info maybe_cc_slot Recursive b e
415 ) `thenFC` \ new_bindings ->
417 addBindsC new_bindings
419 -- We add the binders to the live-in-rhss set so that we don't
420 -- delete the bindings for the binder from the environment!
421 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
424 :: StgLiveVars -- Live in rhss
426 -> Maybe VirtualSpOffset
430 -> FCode (Id, CgIdInfo)
432 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
433 (StgRhsClosure cc bi srt _ upd_flag args body)
434 = -- We could check the update flag, but currently we don't switch it off
435 -- for let-no-escaped things, so we omit the check too!
437 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
438 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
439 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
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 binder
445 (StgRhsCon cc con args)
446 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
447 [] --No args; the binder is data structure, not a function
448 (StgCon (DataCon con) args (idType binder))
451 Little helper for primitives that return unboxed tuples.
455 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
456 primRetUnboxedTuple op args res_ty
457 = getArgAmodes args `thenFC` \ arg_amodes ->
459 put all the arguments in temporaries so they don't get stomped when
460 we push the return address.
464 arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
465 arg_reps = map getArgPrimRep args
466 arg_temps = zipWith CTemp arg_uniqs arg_reps
468 absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
470 allocate some temporaries for the return values.
473 (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of
474 Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
476 prim_reps = map typePrimRep ty_args
477 temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
478 temp_amodes = zipWith CTemp temp_uniqs prim_reps
480 returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))