2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.23 1999/04/23 13:53:29 simonm 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 splitTyConAppThroughNewTypes )
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 )
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 | isEnumerationTyCon tycon =
130 getArgAmode arg `thenFC` \amode ->
131 performReturn (CAssign (CReg node)
133 (CLbl (mkClosureTblLabel tycon) PtrRep)
135 (\ sequel -> mkDynamicAlgReturnCode tycon amode sequel)
137 | otherwise = panic "cgExpr: tagToEnum# of non-enumerated type"
140 (Just (tycon,_)) = splitTyConApp_maybe res_ty
143 cgExpr x@(StgCon (PrimOp op) args res_ty)
144 | primOpOutOfLine op = tailCallPrimOp op args
146 = ASSERT(op /= SeqOp) -- can't handle SeqOp
148 getArgAmodes args `thenFC` \ arg_amodes ->
150 case (getPrimOpResultInfo op) of
153 let result_amode = CReg (dataReturnConvPrim kind) in
155 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
156 (mkPrimReturnCode (text "primapp)" <+> ppr x))
158 -- otherwise, must be returning an enumerated type (eg. Bool).
159 -- we've only got the tag in R2, so we have to load the constructor
163 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
165 | isEnumerationTyCon tycon ->
167 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
169 absC (CAssign (CReg node) closure_lbl) `thenC`
170 mkDynamicAlgReturnCode tycon dyn_tag sequel)
173 -- Pull a unique out of thin air to put the tag in.
174 -- It shouldn't matter if this overlaps with anything - we're
175 -- about to return anyway.
176 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
178 closure_lbl = CTableEntry
179 (CLbl (mkClosureTblLabel tycon) PtrRep)
184 %********************************************************
186 %* Case expressions *
188 %********************************************************
189 Case-expression conversion is complicated enough to have its own
193 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
194 = cgCase expr live_vars save_vars bndr srt alts
198 %********************************************************
202 %********************************************************
203 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
206 cgExpr (StgLet (StgNonRec name rhs) expr)
207 = cgRhs name rhs `thenFC` \ (name, info) ->
208 addBindC name info `thenC`
211 cgExpr (StgLet (StgRec pairs) expr)
212 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
213 listFCs [ cgRhs b e | (b,e) <- pairs ]
214 ) `thenFC` \ new_bindings ->
216 addBindsC new_bindings `thenC`
221 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
222 = -- Figure out what volatile variables to save
223 nukeDeadBindings live_in_whole_let `thenC`
224 saveVolatileVarsAndRegs live_in_rhss
225 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
226 -- ToDo: cost centre???
227 freeCostCentreSlot maybe_cc_slot `thenC`
228 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
230 -- Save those variables right now!
231 absC save_assts `thenC`
233 -- Produce code for the rhss
234 -- and add suitable bindings to the environment
235 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
238 setEndOfBlockInfo rhs_eob_info (cgExpr body)
242 %********************************************************
246 %********************************************************
248 SCC expressions are treated specially. They set the current cost
251 cgExpr (StgSCC cc expr)
252 = ASSERT(sccAbleCostCentre cc)
255 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
260 ToDo: counting of dict sccs ...
262 %********************************************************
264 %* Non-top-level bindings *
266 %********************************************************
267 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
269 We rely on the support code in @CgCon@ (to do constructors) and
270 in @CgClosure@ (to do closures).
273 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
274 -- the Id is passed along so a binding can be set up
276 cgRhs name (StgRhsCon maybe_cc con args)
277 = getArgAmodes args `thenFC` \ amodes ->
278 buildDynCon name maybe_cc con amodes (all zero_size args)
280 returnFC (name, idinfo)
282 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
284 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
285 = mkRhsClosure name cc bi srt fvs upd_flag args body
286 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
287 = mkRhsClosure name cc bi srt fvs upd_flag args body
290 mkRhsClosure looks for two special forms of the right-hand side:
294 If neither happens, it just calls mkClosureLFInfo. You might think
295 that mkClosureLFInfo should do all this, but it seems wrong for the
296 latter to look at the structure of an expression
300 We look at the body of the closure to see if it's a selector---turgid,
301 but nothing deep. We are looking for a closure of {\em exactly} the
304 ... = [the_fv] \ u [] ->
306 con a_1 ... a_n -> a_i
310 mkRhsClosure bndr cc bi srt
311 [the_fv] -- Just one free var
312 upd_flag -- Updatable thunk
314 body@(StgCase (StgApp scrutinee [{-no args-}])
315 _ _ _ _ -- ignore uniq, etc.
317 [(con, params, use_mask,
318 (StgApp selectee [{-no args-}]))]
320 | the_fv == scrutinee -- Scrutinee is the only free variable
321 && maybeToBool maybe_offset -- Selectee is a component of the tuple
322 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
323 = ASSERT(is_single_constructor)
324 cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
326 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
327 (isUpdatable upd_flag)
328 (_, params_w_offsets) = layOutDynCon con idPrimRep params
329 maybe_offset = assocMaybe params_w_offsets selectee
330 Just the_offset = maybe_offset
331 offset_into_int = the_offset - fixedHdrSize
332 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
333 tycon = dataConTyCon con
340 A more generic AP thunk of the form
342 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
344 A set of these is compiled statically into the RTS, so we just use
345 those. We could extend the idea to thunks where some of the x_i are
346 global ids (and hence not free variables), but this would entail
347 generating a larger thunk. It might be an option for non-optimising
350 We only generate an Ap thunk if all the free variables are pointers,
351 for semi-obvious reasons.
354 mkRhsClosure bndr cc bi srt
357 [] -- No args; a thunk
358 body@(StgApp fun_id args)
360 | length args + 1 == arity
361 && all isFollowableRep (map idPrimRep fvs)
362 && isUpdatable upd_flag
363 && arity <= mAX_SPEC_AP_SIZE
366 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
369 lf_info = mkApLFInfo (idType bndr) upd_flag arity
370 -- the payload has to be in the correct order, hence we can't
372 payload = StgVarArg fun_id : args
379 mkRhsClosure bndr cc bi srt fvs upd_flag args body
380 = getSRTLabel `thenFC` \ srt_label ->
382 mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
384 cgRhsClosure bndr cc bi fvs args body lf_info
388 %********************************************************
390 %* Let-no-escape bindings
392 %********************************************************
394 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
395 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
396 NonRecursive binder rhs
397 `thenFC` \ (binder, info) ->
400 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
401 = fixC (\ new_bindings ->
402 addBindsC new_bindings `thenC`
403 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
404 rhs_eob_info maybe_cc_slot Recursive b e
406 ) `thenFC` \ new_bindings ->
408 addBindsC new_bindings
410 -- We add the binders to the live-in-rhss set so that we don't
411 -- delete the bindings for the binder from the environment!
412 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
415 :: StgLiveVars -- Live in rhss
417 -> Maybe VirtualSpOffset
421 -> FCode (Id, CgIdInfo)
423 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
424 (StgRhsClosure cc bi srt _ upd_flag args body)
425 = -- We could check the update flag, but currently we don't switch it off
426 -- for let-no-escaped things, so we omit the check too!
428 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
429 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
430 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
432 -- For a constructor RHS we want to generate a single chunk of code which
433 -- can be jumped to from many places, which will return the constructor.
434 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
435 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
436 (StgRhsCon cc con args)
437 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
438 [] --No args; the binder is data structure, not a function
439 (StgCon (DataCon con) args (idType binder))
442 Little helper for primitives that return unboxed tuples.
446 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
447 primRetUnboxedTuple op args res_ty
448 = getArgAmodes args `thenFC` \ arg_amodes ->
450 put all the arguments in temporaries so they don't get stomped when
451 we push the return address.
455 arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
456 arg_reps = map getArgPrimRep args
457 arg_temps = zipWith CTemp arg_uniqs arg_reps
459 absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
461 allocate some temporaries for the return values.
464 (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
465 Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
467 prim_reps = map typePrimRep ty_args
468 temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
469 temp_amodes = zipWith CTemp temp_uniqs prim_reps
471 returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))