2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgExpr.lhs,v 1.34 2000/04/13 20:41:30 panne 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 IdInfo ( ArityInfo(..) )
44 import PrimOp ( primOpOutOfLine, ccallMayGC,
45 getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
47 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
48 import TyCon ( maybeTyConSingleCon,
49 isUnboxedTupleTyCon, isEnumerationTyCon )
50 import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
51 import PprType ( {- instance Outputable Type -} )
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 (StgConApp con args)
89 = getArgAmodes args `thenFC` \ amodes ->
90 cgReturnDataCon con amodes
93 Literals are similar to constructors; they return by putting
94 themselves in an appropriate register and returning to the address on
99 = performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
103 %********************************************************
105 %* STG PrimApps (unboxed primitive ops) *
107 %********************************************************
109 Here is where we insert real live machine instructions.
111 NOTE about _ccall_GC_:
113 A _ccall_GC_ is treated as an out-of-line primop (returns True
114 for primOpOutOfLine) so that when we see the call in case context
115 case (ccall ...) of { ... }
116 we get a proper stack frame on the stack when we perform it. When we
117 get in a tail-call position, however, we need to actually perform the
118 call, so we treat it as an inline primop.
121 cgExpr (StgPrimApp op@(CCallOp ccall) 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 (StgPrimApp 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)
137 dyn_tag PtrRep) PtrRep))
138 (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
140 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
142 -- if you're reading this code in the attempt to figure
143 -- out why the compiler panic'ed here, it is probably because
144 -- you used tagToEnum# in a non-monomorphic setting, e.g.,
145 -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
149 (Just (tycon,_)) = splitTyConApp_maybe res_ty
152 cgExpr x@(StgPrimApp op args res_ty)
153 | primOpOutOfLine op = tailCallPrimOp op args
155 = ASSERT(op /= SeqOp) -- can't handle SeqOp
157 getArgAmodes args `thenFC` \ arg_amodes ->
159 case (getPrimOpResultInfo op) of
162 let result_amode = CReg (dataReturnConvPrim kind) in
164 (COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
165 (mkPrimReturnCode (text "primapp)" <+> ppr x))
167 -- otherwise, must be returning an enumerated type (eg. Bool).
168 -- we've only got the tag in R2, so we have to load the constructor
172 | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
174 | isEnumerationTyCon tycon ->
176 (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
178 absC (CAssign (CReg node) closure_lbl) `thenC`
179 mkDynamicAlgReturnCode tycon dyn_tag sequel)
182 -- Pull a unique out of thin air to put the tag in.
183 -- It shouldn't matter if this overlaps with anything - we're
184 -- about to return anyway.
185 dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
187 closure_lbl = CVal (CIndex
188 (CLbl (mkClosureTblLabel tycon) PtrRep)
189 dyn_tag PtrRep) PtrRep
193 %********************************************************
195 %* Case expressions *
197 %********************************************************
198 Case-expression conversion is complicated enough to have its own
202 cgExpr (StgCase expr live_vars save_vars bndr srt alts)
203 = cgCase expr live_vars save_vars bndr srt alts
207 %********************************************************
211 %********************************************************
212 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
215 cgExpr (StgLet (StgNonRec name rhs) expr)
216 = cgRhs name rhs `thenFC` \ (name, info) ->
217 addBindC name info `thenC`
220 cgExpr (StgLet (StgRec pairs) expr)
221 = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
222 listFCs [ cgRhs b e | (b,e) <- pairs ]
223 ) `thenFC` \ new_bindings ->
225 addBindsC new_bindings `thenC`
230 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
231 = -- Figure out what volatile variables to save
232 nukeDeadBindings live_in_whole_let `thenC`
233 saveVolatileVarsAndRegs live_in_rhss
234 `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
235 -- ToDo: cost centre???
236 restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
238 -- Save those variables right now!
239 absC save_assts `thenC`
241 -- Produce code for the rhss
242 -- and add suitable bindings to the environment
243 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC`
246 setEndOfBlockInfo rhs_eob_info (cgExpr body)
250 %********************************************************
254 %********************************************************
256 SCC expressions are treated specially. They set the current cost
259 cgExpr (StgSCC cc expr)
260 = ASSERT(sccAbleCostCentre cc)
263 [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
268 ToDo: counting of dict sccs ...
270 %********************************************************
272 %* Non-top-level bindings *
274 %********************************************************
275 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
277 We rely on the support code in @CgCon@ (to do constructors) and
278 in @CgClosure@ (to do closures).
281 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
282 -- the Id is passed along so a binding can be set up
284 cgRhs name (StgRhsCon maybe_cc con args)
285 = getArgAmodes args `thenFC` \ amodes ->
286 buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
287 returnFC (name, idinfo)
289 cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
290 = mkRhsClosure name cc bi srt fvs upd_flag args body
291 cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
292 = mkRhsClosure name cc bi srt fvs upd_flag args body
295 mkRhsClosure looks for two special forms of the right-hand side:
299 If neither happens, it just calls mkClosureLFInfo. You might think
300 that mkClosureLFInfo should do all this, but it seems wrong for the
301 latter to look at the structure of an expression
305 We look at the body of the closure to see if it's a selector---turgid,
306 but nothing deep. We are looking for a closure of {\em exactly} the
309 ... = [the_fv] \ u [] ->
311 con a_1 ... a_n -> a_i
315 mkRhsClosure bndr cc bi srt
316 [the_fv] -- Just one free var
317 upd_flag -- Updatable thunk
319 body@(StgCase (StgApp scrutinee [{-no args-}])
320 _ _ _ _ -- ignore uniq, etc.
322 [(con, params, use_mask,
323 (StgApp selectee [{-no args-}]))]
325 | the_fv == scrutinee -- Scrutinee is the only free variable
326 && maybeToBool maybe_offset -- Selectee is a component of the tuple
327 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
328 = ASSERT(is_single_constructor)
329 cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
331 lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
332 (isUpdatable upd_flag)
333 (_, params_w_offsets) = layOutDynCon con idPrimRep params
334 maybe_offset = assocMaybe params_w_offsets selectee
335 Just the_offset = maybe_offset
336 offset_into_int = the_offset - fixedHdrSize
337 is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
338 tycon = dataConTyCon con
345 A more generic AP thunk of the form
347 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
349 A set of these is compiled statically into the RTS, so we just use
350 those. We could extend the idea to thunks where some of the x_i are
351 global ids (and hence not free variables), but this would entail
352 generating a larger thunk. It might be an option for non-optimising
355 We only generate an Ap thunk if all the free variables are pointers,
356 for semi-obvious reasons.
359 mkRhsClosure bndr cc bi srt
362 [] -- No args; a thunk
363 body@(StgApp fun_id args)
365 | length args + 1 == arity
366 && all isFollowableRep (map idPrimRep fvs)
367 && isUpdatable upd_flag
368 && arity <= mAX_SPEC_AP_SIZE
371 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
374 lf_info = mkApLFInfo (idType bndr) upd_flag arity
375 -- the payload has to be in the correct order, hence we can't
377 payload = StgVarArg fun_id : args
384 mkRhsClosure bndr cc bi srt fvs upd_flag args body
385 = getSRTLabel `thenFC` \ srt_label ->
387 mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
389 cgRhsClosure bndr cc bi fvs args body lf_info
393 %********************************************************
395 %* Let-no-escape bindings
397 %********************************************************
399 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
400 = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
401 NonRecursive binder rhs
402 `thenFC` \ (binder, info) ->
405 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
406 = fixC (\ new_bindings ->
407 addBindsC new_bindings `thenC`
408 listFCs [ cgLetNoEscapeRhs full_live_in_rhss
409 rhs_eob_info maybe_cc_slot Recursive b e
411 ) `thenFC` \ new_bindings ->
413 addBindsC new_bindings
415 -- We add the binders to the live-in-rhss set so that we don't
416 -- delete the bindings for the binder from the environment!
417 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
420 :: StgLiveVars -- Live in rhss
422 -> Maybe VirtualSpOffset
426 -> FCode (Id, CgIdInfo)
428 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
429 (StgRhsClosure cc bi srt _ upd_flag args body)
430 = -- We could check the update flag, but currently we don't switch it off
431 -- for let-no-escaped things, so we omit the check too!
433 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
434 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
435 cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
437 -- For a constructor RHS we want to generate a single chunk of code which
438 -- can be jumped to from many places, which will return the constructor.
439 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
440 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
441 (StgRhsCon cc con args)
442 = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec
443 [] --No args; the binder is data structure, not a function
447 Little helper for primitives that return unboxed tuples.
451 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
452 primRetUnboxedTuple op args res_ty
453 = getArgAmodes args `thenFC` \ arg_amodes ->
455 put all the arguments in temporaries so they don't get stomped when
456 we push the return address.
460 arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
461 arg_reps = map getArgPrimRep args
462 arg_temps = zipWith CTemp arg_uniqs arg_reps
464 absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
466 allocate some temporaries for the return values.
469 (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of
470 Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
472 prim_reps = map typePrimRep ty_args
473 temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
474 temp_amodes = zipWith CTemp temp_uniqs prim_reps
476 returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))