2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.15 1998/12/02 13:17:49 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 CLabel ( mkClosureTblLabel )
23 import SMRep ( fixedHdrSize )
24 import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
25 import CgCase ( cgCase, saveVolatileVarsAndRegs,
26 restoreCurrentCostCentre,
27 splitAlgTyConAppThroughNewTypes )
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, isDictCC, 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 )
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 (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 an an inline primop.
121 cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
122 = primRetUnboxedTuple op args res_ty
124 cgExpr x@(StgCon (PrimOp op) args res_ty)
125 | primOpOutOfLine op = tailCallPrimOp op args
127 = ASSERT(op /= SeqOp) -- can't handle SeqOp
129 getArgAmodes args `thenFC` \ arg_amodes ->
131 case (getPrimOpResultInfo op) of
134 let result_amode = CReg (dataReturnConvPrim kind) in
136 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
137 (\ sequel -> mkPrimReturnCode sequel)
139 -- otherwise, must be returning an enumerated type (eg. Bool).
140 -- we've only got the tag in R2, so we have to load the constructor
144 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
147 | isEnumerationTyCon tycon ->
149 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
151 absC (CAssign (CReg node) closure_lbl) `thenC`
152 mkDynamicAlgReturnCode tycon dyn_tag sequel)
155 -- Pull a unique out of thin air to put the tag in.
156 -- It shouldn't matter if this overlaps with anything - we're
157 -- about to return anyway.
158 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
160 closure_lbl = CTableEntry
161 (CLbl (mkClosureTblLabel tycon) PtrRep)
166 %********************************************************
168 %* Case expressions *
170 %********************************************************
171 Case-expression conversion is complicated enough to have its own
175 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
176 = cgCase expr live_vars save_vars bndr srt alts
180 %********************************************************
184 %********************************************************
185 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
188 cgExpr (StgLet (StgNonRec name rhs) expr)
189 = cgRhs name rhs `thenFC` \ (name, info) ->
190 addBindC name info `thenC`
193 cgExpr (StgLet (StgRec pairs) expr)
194 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
195 listFCs [ cgRhs b e | (b,e) <- pairs ]
196 ) `thenFC` \ new_bindings ->
198 addBindsC new_bindings `thenC`
203 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
204 = -- Figure out what volatile variables to save
205 nukeDeadBindings live_in_whole_let `thenC`
206 saveVolatileVarsAndRegs live_in_rhss
207 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
208 -- ToDo: cost centre???
209 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
211 -- Save those variables right now!
212 absC save_assts `thenC`
214 -- Produce code for the rhss
215 -- and add suitable bindings to the environment
216 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
219 setEndOfBlockInfo rhs_eob_info (cgExpr body)
223 %********************************************************
227 %********************************************************
229 SCC expressions are treated specially. They set the current cost
232 cgExpr (StgSCC cc expr)
233 = ASSERT(sccAbleCostCentre cc)
235 (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
236 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
241 ToDo: counting of dict sccs ...
243 %********************************************************
245 %* Non-top-level bindings *
247 %********************************************************
248 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
250 We rely on the support code in @CgCon@ (to do constructors) and
251 in @CgClosure@ (to do closures).
254 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
255 -- the Id is passed along so a binding can be set up
257 cgRhs name (StgRhsCon maybe_cc con args)
258 = getArgAmodes args `thenFC` \ amodes ->
259 buildDynCon name maybe_cc con amodes (all zero_size args)
261 returnFC (name, idinfo)
263 zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
265 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
266 = mkRhsClosure name cc bi srt fvs upd_flag args body
267 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
268 = mkRhsClosure name cc bi srt fvs upd_flag args body
271 mkRhsClosure looks for two special forms of the right-hand side:
275 If neither happens, it just calls mkClosureLFInfo. You might think
276 that mkClosureLFInfo should do all this, but it seems wrong for the
277 latter to look at the structure of an expression
281 We look at the body of the closure to see if it's a selector---turgid,
282 but nothing deep. We are looking for a closure of {\em exactly} the
285 ... = [the_fv] \ u [] ->
287 con a_1 ... a_n -> a_i
291 mkRhsClosure bndr cc bi srt
292 [the_fv] -- Just one free var
293 upd_flag -- Updatable thunk
295 body@(StgCase (StgApp scrutinee [{-no args-}])
296 _ _ _ _ -- ignore uniq, etc.
298 [(con, params, use_mask,
299 (StgApp selectee [{-no args-}]))]
301 | the_fv == scrutinee -- Scrutinee is the only free variable
302 && maybeToBool maybe_offset -- Selectee is a component of the tuple
303 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
304 = ASSERT(is_single_constructor)
305 cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv]
307 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
308 (isUpdatable upd_flag)
309 (_, params_w_offsets) = layOutDynCon con idPrimRep params
310 maybe_offset = assocMaybe params_w_offsets selectee
311 Just the_offset = maybe_offset
312 offset_into_int = the_offset - fixedHdrSize
313 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
314 tycon = dataConTyCon con
321 A more generic AP thunk of the form
323 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
325 A set of these is compiled statically into the RTS, so we just use
326 those. We could extend the idea to thunks where some of the x_i are
327 global ids (and hence not free variables), but this would entail
328 generating a larger thunk. It might be an option for non-optimising
331 We only generate an Ap thunk if all the free variables are pointers,
332 for semi-obvious reasons.
335 mkRhsClosure bndr cc bi srt
338 [] -- No args; a thunk
339 body@(StgApp fun_id args)
341 | length args + 1 == arity
342 && all isFollowableRep (map idPrimRep fvs)
343 && isUpdatable upd_flag
344 && arity <= mAX_SPEC_AP_SIZE
347 = cgStdRhsClosure bndr cc bi srt fvs [] body lf_info payload
350 lf_info = mkApLFInfo (idType bndr) upd_flag arity
351 -- the payload has to be in the correct order, hence we can't
353 payload = StgVarArg fun_id : args
360 mkRhsClosure bndr cc bi srt fvs upd_flag args body
361 = cgRhsClosure bndr cc bi srt fvs args body lf_info
362 where lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
366 %********************************************************
368 %* Let-no-escape bindings
370 %********************************************************
372 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
373 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
374 NonRecursive binder rhs
375 `thenFC` \ (binder, info) ->
378 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
379 = fixC (\ new_bindings ->
380 addBindsC new_bindings `thenC`
381 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
382 rhs_eob_info maybe_cc_slot Recursive b e
384 ) `thenFC` \ new_bindings ->
386 addBindsC new_bindings
388 -- We add the binders to the live-in-rhss set so that we don't
389 -- delete the bindings for the binder from the environment!
390 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
393 :: StgLiveVars -- Live in rhss
395 -> Maybe VirtualSpOffset
399 -> FCode (Id, CgIdInfo)
401 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
402 (StgRhsClosure cc bi srt _ upd_flag args body)
403 = -- We could check the update flag, but currently we don't switch it off
404 -- for let-no-escaped things, so we omit the check too!
406 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
407 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
408 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
410 -- For a constructor RHS we want to generate a single chunk of code which
411 -- can be jumped to from many places, which will return the constructor.
412 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
413 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
414 (StgRhsCon cc con args)
415 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
416 [] --No args; the binder is data structure, not a function
417 (StgCon (DataCon con) args (idType binder))
420 Little helper for primitives that return unboxed tuples.
424 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
425 primRetUnboxedTuple op args res_ty
426 = let Just (tc,ty_args) = splitAlgTyConAppThroughNewTypes res_ty
427 prim_reps = map typePrimRep ty_args
428 temp_uniqs = map mkBuiltinUnique [0..length ty_args]
429 temp_amodes = zipWith CTemp temp_uniqs prim_reps
431 returnUnboxedTuple temp_amodes
432 (getArgAmodes args `thenFC` \ arg_amodes ->
433 absC (COpStmt temp_amodes op arg_amodes []))