2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.25 1999/05/18 15:03:49 simonpj 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, nukeDeadBindings)
26 import CgCase ( cgCase, saveVolatileVarsAndRegs,
27 restoreCurrentCostCentre, freeCostCentreSlot )
28 import CgClosure ( cgRhsClosure, cgStdRhsClosure )
29 import CgCon ( buildDynCon, cgReturnDataCon )
30 import CgLetNoEscape ( cgLetNoEscapeClosure )
31 import CgRetConv ( dataReturnConvPrim )
32 import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
33 mkDynamicAlgReturnCode, mkPrimReturnCode,
34 tailCallPrimOp, returnUnboxedTuple
36 import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
37 mkApLFInfo, layOutDynCon )
38 import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
39 import Id ( idPrimRep, idType, Id )
41 import DataCon ( DataCon, dataConTyCon )
42 import Const ( Con(..) )
43 import IdInfo ( ArityInfo(..) )
44 import PrimOp ( primOpOutOfLine,
45 getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
47 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
48 import TyCon ( maybeTyConSingleCon,
49 isUnboxedTupleTyCon, isEnumerationTyCon )
50 import Type ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe )
51 import Maybes ( assocMaybe, maybeToBool )
52 import Unique ( mkBuiltinUnique )
53 import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
57 This module provides the support code for @StgToAbstractC@ to deal
58 with STG {\em expressions}. See also @CgClosure@, which deals
59 with closures, and @CgCon@, which deals with constructors.
62 cgExpr :: StgExpr -- input
66 %********************************************************
70 %********************************************************
72 ``Applications'' mean {\em tail calls}, a service provided by module
73 @CgTailCall@. This includes literals, which show up as
74 @(STGApp (StgLitArg 42) [])@.
77 cgExpr (StgApp fun args) = cgTailCall fun args
80 %********************************************************
82 %* STG ConApps (for inline versions) *
84 %********************************************************
87 cgExpr (StgCon (DataCon con) args res_ty)
88 = getArgAmodes args `thenFC` \ amodes ->
89 cgReturnDataCon con amodes (all zero_size args)
91 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
94 Literals are similar to constructors; they return by putting
95 themselves in an appropriate register and returning to the address on
99 cgExpr (StgCon (Literal lit) args res_ty)
100 = ASSERT( null args )
101 performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
105 %********************************************************
107 %* STG PrimApps (unboxed primitive ops) *
109 %********************************************************
111 Here is where we insert real live machine instructions.
113 NOTE about _ccall_GC_:
115 A _ccall_GC_ is treated as an out-of-line primop for the case
116 expression code, because we want a proper stack frame on the stack
117 when we perform it. When we get here, however, we need to actually
118 perform the call, so we treat it as an inline primop.
121 cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
122 = primRetUnboxedTuple op args res_ty
124 -- tagToEnum# is special: we need to pull the constructor out of the table,
125 -- and perform an appropriate return.
127 cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
128 = ASSERT(isEnumerationTyCon tycon)
129 getArgAmode arg `thenFC` \amode ->
130 -- save the tag in a temporary in case amode overlaps
132 absC (CAssign dyn_tag amode) `thenC`
136 (CLbl (mkClosureTblLabel tycon) PtrRep)
138 (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
140 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
141 (Just (tycon,_)) = splitTyConApp_maybe res_ty
144 cgExpr x@(StgCon (PrimOp op) args res_ty)
145 | primOpOutOfLine op = tailCallPrimOp op args
147 = ASSERT(op /= SeqOp) -- can't handle SeqOp
149 getArgAmodes args `thenFC` \ arg_amodes ->
151 case (getPrimOpResultInfo op) of
154 let result_amode = CReg (dataReturnConvPrim kind) in
156 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
157 (mkPrimReturnCode (text "primapp)" <+> ppr x))
159 -- otherwise, must be returning an enumerated type (eg. Bool).
160 -- we've only got the tag in R2, so we have to load the constructor
164 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
166 | isEnumerationTyCon tycon ->
168 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
170 absC (CAssign (CReg node) closure_lbl) `thenC`
171 mkDynamicAlgReturnCode tycon dyn_tag sequel)
174 -- Pull a unique out of thin air to put the tag in.
175 -- It shouldn't matter if this overlaps with anything - we're
176 -- about to return anyway.
177 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
179 closure_lbl = CTableEntry
180 (CLbl (mkClosureTblLabel tycon) PtrRep)
185 %********************************************************
187 %* Case expressions *
189 %********************************************************
190 Case-expression conversion is complicated enough to have its own
194 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
195 = cgCase expr live_vars save_vars bndr srt alts
199 %********************************************************
203 %********************************************************
204 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
207 cgExpr (StgLet (StgNonRec name rhs) expr)
208 = cgRhs name rhs `thenFC` \ (name, info) ->
209 addBindC name info `thenC`
212 cgExpr (StgLet (StgRec pairs) expr)
213 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
214 listFCs [ cgRhs b e | (b,e) <- pairs ]
215 ) `thenFC` \ new_bindings ->
217 addBindsC new_bindings `thenC`
222 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
223 = -- Figure out what volatile variables to save
224 nukeDeadBindings live_in_whole_let `thenC`
225 saveVolatileVarsAndRegs live_in_rhss
226 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
227 -- ToDo: cost centre???
228 freeCostCentreSlot maybe_cc_slot `thenC`
229 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
231 -- Save those variables right now!
232 absC save_assts `thenC`
234 -- Produce code for the rhss
235 -- and add suitable bindings to the environment
236 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
239 setEndOfBlockInfo rhs_eob_info (cgExpr body)
243 %********************************************************
247 %********************************************************
249 SCC expressions are treated specially. They set the current cost
252 cgExpr (StgSCC cc expr)
253 = ASSERT(sccAbleCostCentre cc)
256 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
261 ToDo: counting of dict sccs ...
263 %********************************************************
265 %* Non-top-level bindings *
267 %********************************************************
268 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
270 We rely on the support code in @CgCon@ (to do constructors) and
271 in @CgClosure@ (to do closures).
274 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
275 -- the Id is passed along so a binding can be set up
277 cgRhs name (StgRhsCon maybe_cc con args)
278 = getArgAmodes args `thenFC` \ amodes ->
279 buildDynCon name maybe_cc con amodes (all zero_size args)
281 returnFC (name, idinfo)
283 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
285 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
286 = mkRhsClosure name cc bi srt fvs upd_flag args body
287 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
288 = mkRhsClosure name cc bi srt fvs upd_flag args body
291 mkRhsClosure looks for two special forms of the right-hand side:
295 If neither happens, it just calls mkClosureLFInfo. You might think
296 that mkClosureLFInfo should do all this, but it seems wrong for the
297 latter to look at the structure of an expression
301 We look at the body of the closure to see if it's a selector---turgid,
302 but nothing deep. We are looking for a closure of {\em exactly} the
305 ... = [the_fv] \ u [] ->
307 con a_1 ... a_n -> a_i
311 mkRhsClosure bndr cc bi srt
312 [the_fv] -- Just one free var
313 upd_flag -- Updatable thunk
315 body@(StgCase (StgApp scrutinee [{-no args-}])
316 _ _ _ _ -- ignore uniq, etc.
318 [(con, params, use_mask,
319 (StgApp selectee [{-no args-}]))]
321 | the_fv == scrutinee -- Scrutinee is the only free variable
322 && maybeToBool maybe_offset -- Selectee is a component of the tuple
323 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
324 = ASSERT(is_single_constructor)
325 cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
327 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
328 (isUpdatable upd_flag)
329 (_, params_w_offsets) = layOutDynCon con idPrimRep params
330 maybe_offset = assocMaybe params_w_offsets selectee
331 Just the_offset = maybe_offset
332 offset_into_int = the_offset - fixedHdrSize
333 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
334 tycon = dataConTyCon con
341 A more generic AP thunk of the form
343 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
345 A set of these is compiled statically into the RTS, so we just use
346 those. We could extend the idea to thunks where some of the x_i are
347 global ids (and hence not free variables), but this would entail
348 generating a larger thunk. It might be an option for non-optimising
351 We only generate an Ap thunk if all the free variables are pointers,
352 for semi-obvious reasons.
355 mkRhsClosure bndr cc bi srt
358 [] -- No args; a thunk
359 body@(StgApp fun_id args)
361 | length args + 1 == arity
362 && all isFollowableRep (map idPrimRep fvs)
363 && isUpdatable upd_flag
364 && arity <= mAX_SPEC_AP_SIZE
367 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
370 lf_info = mkApLFInfo (idType bndr) upd_flag arity
371 -- the payload has to be in the correct order, hence we can't
373 payload = StgVarArg fun_id : args
380 mkRhsClosure bndr cc bi srt fvs upd_flag args body
381 = getSRTLabel `thenFC` \ srt_label ->
383 mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
385 cgRhsClosure bndr cc bi fvs args body lf_info
389 %********************************************************
391 %* Let-no-escape bindings
393 %********************************************************
395 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
396 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
397 NonRecursive binder rhs
398 `thenFC` \ (binder, info) ->
401 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
402 = fixC (\ new_bindings ->
403 addBindsC new_bindings `thenC`
404 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
405 rhs_eob_info maybe_cc_slot Recursive b e
407 ) `thenFC` \ new_bindings ->
409 addBindsC new_bindings
411 -- We add the binders to the live-in-rhss set so that we don't
412 -- delete the bindings for the binder from the environment!
413 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
416 :: StgLiveVars -- Live in rhss
418 -> Maybe VirtualSpOffset
422 -> FCode (Id, CgIdInfo)
424 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
425 (StgRhsClosure cc bi srt _ upd_flag args body)
426 = -- We could check the update flag, but currently we don't switch it off
427 -- for let-no-escaped things, so we omit the check too!
429 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
430 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
431 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
433 -- For a constructor RHS we want to generate a single chunk of code which
434 -- can be jumped to from many places, which will return the constructor.
435 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
436 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
437 (StgRhsCon cc con args)
438 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
439 [] --No args; the binder is data structure, not a function
440 (StgCon (DataCon con) args (idType binder))
443 Little helper for primitives that return unboxed tuples.
447 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
448 primRetUnboxedTuple op args res_ty
449 = getArgAmodes args `thenFC` \ arg_amodes ->
451 put all the arguments in temporaries so they don't get stomped when
452 we push the return address.
456 arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
457 arg_reps = map getArgPrimRep args
458 arg_temps = zipWith CTemp arg_uniqs arg_reps
460 absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
462 allocate some temporaries for the return values.
465 (tc,ty_args) = case splitRepTyConApp_maybe res_ty of
466 Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
468 prim_reps = map typePrimRep ty_args
469 temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
470 temp_amodes = zipWith CTemp temp_uniqs prim_reps
472 returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))