2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.36 2000/10/03 08:43:00 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,
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 PrimOp ( primOpOutOfLine, ccallMayGC,
44 getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
46 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
47 import TyCon ( maybeTyConSingleCon,
48 isUnboxedTupleTyCon, isEnumerationTyCon )
49 import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
50 import Maybes ( maybeToBool )
51 import ListSetOps ( assocMaybe )
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 (StgConApp con args)
88 = getArgAmodes args `thenFC` \ amodes ->
89 cgReturnDataCon con amodes
92 Literals are similar to constructors; they return by putting
93 themselves in an appropriate register and returning to the address on
98 = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
102 %********************************************************
104 %* STG PrimApps (unboxed primitive ops) *
106 %********************************************************
108 Here is where we insert real live machine instructions.
110 NOTE about _ccall_GC_:
112 A _ccall_GC_ is treated as an out-of-line primop (returns True
113 for primOpOutOfLine) so that when we see the call in case context
114 case (ccall ...) of { ... }
115 we get a proper stack frame on the stack when we perform it. When we
116 get in a tail-call position, however, we need to actually perform the
117 call, so we treat it as an inline primop.
120 cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty)
121 = primRetUnboxedTuple op args res_ty
123 -- tagToEnum# is special: we need to pull the constructor out of the table,
124 -- and perform an appropriate return.
126 cgExpr (StgPrimApp TagToEnumOp [arg] res_ty)
127 = ASSERT(isEnumerationTyCon tycon)
128 getArgAmode arg `thenFC` \amode ->
129 -- save the tag in a temporary in case amode overlaps
131 absC (CAssign dyn_tag amode) `thenC`
135 (CLbl (mkClosureTblLabel tycon) PtrRep)
136 dyn_tag PtrRep) PtrRep))
137 (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
139 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
141 -- if you're reading this code in the attempt to figure
142 -- out why the compiler panic'ed here, it is probably because
143 -- you used tagToEnum# in a non-monomorphic setting, e.g.,
144 -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
148 (Just (tycon,_)) = splitTyConApp_maybe res_ty
151 cgExpr x@(StgPrimApp op args res_ty)
152 | primOpOutOfLine op = tailCallPrimOp op args
154 = ASSERT(op /= SeqOp) -- can't handle SeqOp
156 getArgAmodes args `thenFC` \ arg_amodes ->
158 case (getPrimOpResultInfo op) of
161 let result_amode = CReg (dataReturnConvPrim kind) in
163 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
164 (mkPrimReturnCode (text "primapp)" <+> ppr x))
166 -- otherwise, must be returning an enumerated type (eg. Bool).
167 -- we've only got the tag in R2, so we have to load the constructor
171 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
173 | isEnumerationTyCon tycon ->
175 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
177 absC (CAssign (CReg node) closure_lbl) `thenC`
178 mkDynamicAlgReturnCode tycon dyn_tag sequel)
181 -- Pull a unique out of thin air to put the tag in.
182 -- It shouldn't matter if this overlaps with anything - we're
183 -- about to return anyway.
184 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
186 closure_lbl = CVal (CIndex
187 (CLbl (mkClosureTblLabel tycon) PtrRep)
188 dyn_tag PtrRep) PtrRep
192 %********************************************************
194 %* Case expressions *
196 %********************************************************
197 Case-expression conversion is complicated enough to have its own
201 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
202 = cgCase expr live_vars save_vars bndr srt alts
206 %********************************************************
210 %********************************************************
211 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
214 cgExpr (StgLet (StgNonRec name rhs) expr)
215 = cgRhs name rhs `thenFC` \ (name, info) ->
216 addBindC name info `thenC`
219 cgExpr (StgLet (StgRec pairs) expr)
220 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
221 listFCs [ cgRhs b e | (b,e) <- pairs ]
222 ) `thenFC` \ new_bindings ->
224 addBindsC new_bindings `thenC`
229 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
230 = -- Figure out what volatile variables to save
231 nukeDeadBindings live_in_whole_let `thenC`
232 saveVolatileVarsAndRegs live_in_rhss
233 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
234 -- ToDo: cost centre???
235 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
237 -- Save those variables right now!
238 absC save_assts `thenC`
240 -- Produce code for the rhss
241 -- and add suitable bindings to the environment
242 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
245 setEndOfBlockInfo rhs_eob_info (cgExpr body)
249 %********************************************************
253 %********************************************************
255 SCC expressions are treated specially. They set the current cost
258 cgExpr (StgSCC cc expr)
259 = ASSERT(sccAbleCostCentre cc)
262 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
267 ToDo: counting of dict sccs ...
269 %********************************************************
271 %* Non-top-level bindings *
273 %********************************************************
274 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
276 We rely on the support code in @CgCon@ (to do constructors) and
277 in @CgClosure@ (to do closures).
280 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
281 -- the Id is passed along so a binding can be set up
283 cgRhs name (StgRhsCon maybe_cc con args)
284 = getArgAmodes args `thenFC` \ amodes ->
285 buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
286 returnFC (name, idinfo)
288 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
289 = mkRhsClosure name cc bi srt fvs upd_flag args body
290 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
291 = mkRhsClosure name cc bi srt fvs upd_flag args body
294 mkRhsClosure looks for two special forms of the right-hand side:
298 If neither happens, it just calls mkClosureLFInfo. You might think
299 that mkClosureLFInfo should do all this, but it seems wrong for the
300 latter to look at the structure of an expression
304 We look at the body of the closure to see if it's a selector---turgid,
305 but nothing deep. We are looking for a closure of {\em exactly} the
308 ... = [the_fv] \ u [] ->
310 con a_1 ... a_n -> a_i
314 mkRhsClosure bndr cc bi srt
315 [the_fv] -- Just one free var
316 upd_flag -- Updatable thunk
318 body@(StgCase (StgApp scrutinee [{-no args-}])
319 _ _ _ _ -- ignore uniq, etc.
321 [(con, params, use_mask,
322 (StgApp selectee [{-no args-}]))]
324 | the_fv == scrutinee -- Scrutinee is the only free variable
325 && maybeToBool maybe_offset -- Selectee is a component of the tuple
326 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
327 = ASSERT(is_single_constructor)
328 cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
330 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
331 (isUpdatable upd_flag)
332 (_, params_w_offsets) = layOutDynCon con idPrimRep params
333 maybe_offset = assocMaybe params_w_offsets selectee
334 Just the_offset = maybe_offset
335 offset_into_int = the_offset - fixedHdrSize
336 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
337 tycon = dataConTyCon con
344 A more generic AP thunk of the form
346 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
348 A set of these is compiled statically into the RTS, so we just use
349 those. We could extend the idea to thunks where some of the x_i are
350 global ids (and hence not free variables), but this would entail
351 generating a larger thunk. It might be an option for non-optimising
354 We only generate an Ap thunk if all the free variables are pointers,
355 for semi-obvious reasons.
358 mkRhsClosure bndr cc bi srt
361 [] -- No args; a thunk
362 body@(StgApp fun_id args)
364 | length args + 1 == arity
365 && all isFollowableRep (map idPrimRep fvs)
366 && isUpdatable upd_flag
367 && arity <= mAX_SPEC_AP_SIZE
370 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
373 lf_info = mkApLFInfo (idType bndr) upd_flag arity
374 -- the payload has to be in the correct order, hence we can't
376 payload = StgVarArg fun_id : args
383 mkRhsClosure bndr cc bi srt fvs upd_flag args body
384 = getSRTLabel `thenFC` \ srt_label ->
386 mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
388 cgRhsClosure bndr cc bi fvs args body lf_info
392 %********************************************************
394 %* Let-no-escape bindings
396 %********************************************************
398 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
399 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
400 NonRecursive binder rhs
401 `thenFC` \ (binder, info) ->
404 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
405 = fixC (\ new_bindings ->
406 addBindsC new_bindings `thenC`
407 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
408 rhs_eob_info maybe_cc_slot Recursive b e
410 ) `thenFC` \ new_bindings ->
412 addBindsC new_bindings
414 -- We add the binders to the live-in-rhss set so that we don't
415 -- delete the bindings for the binder from the environment!
416 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
419 :: StgLiveVars -- Live in rhss
421 -> Maybe VirtualSpOffset
425 -> FCode (Id, CgIdInfo)
427 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
428 (StgRhsClosure cc bi srt _ upd_flag args body)
429 = -- We could check the update flag, but currently we don't switch it off
430 -- for let-no-escaped things, so we omit the check too!
432 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
433 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
434 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
436 -- For a constructor RHS we want to generate a single chunk of code which
437 -- can be jumped to from many places, which will return the constructor.
438 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
439 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
440 (StgRhsCon cc con args)
441 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
442 [] --No args; the binder is data structure, not a function
446 Little helper for primitives that return unboxed tuples.
450 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
451 primRetUnboxedTuple op args res_ty
452 = getArgAmodes args `thenFC` \ arg_amodes ->
454 put all the arguments in temporaries so they don't get stomped when
455 we push the return address.
459 arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
460 arg_reps = map getArgPrimRep args
461 arg_temps = zipWith CTemp arg_uniqs arg_reps
463 absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
465 allocate some temporaries for the return values.
468 (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of
469 Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
471 prim_reps = map typePrimRep ty_args
472 temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
473 temp_amodes = zipWith CTemp temp_uniqs prim_reps
475 returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))