2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module CgExpr ( cgExpr ) where
16 #include "HsVersions.h"
55 This module provides the support code for @StgToAbstractC@ to deal
56 with STG {\em expressions}. See also @CgClosure@, which deals
57 with closures, and @CgCon@, which deals with constructors.
60 cgExpr :: StgExpr -- input
64 %********************************************************
68 %********************************************************
70 ``Applications'' mean {\em tail calls}, a service provided by module
71 @CgTailCall@. This includes literals, which show up as
72 @(STGApp (StgLitArg 42) [])@.
75 cgExpr (StgApp fun args) = cgTailCall fun args
78 %********************************************************
80 %* STG ConApps (for inline versions) *
82 %********************************************************
85 cgExpr (StgConApp con args)
86 = do { amodes <- getArgAmodes args
87 ; cgReturnDataCon con amodes }
90 Literals are similar to constructors; they return by putting
91 themselves in an appropriate register and returning to the address on
96 = do { cmm_lit <- cgLit lit
97 ; performPrimReturn rep (CmmLit cmm_lit) }
99 rep = (typeCgRep) (literalType lit)
103 %********************************************************
105 %* PrimOps and foreign calls.
107 %********************************************************
109 NOTE about "safe" foreign calls: a safe foreign call is never compiled
110 inline in a case expression. When we see
112 case (ccall ...) of { ... }
114 We generate a proper return address for the alternatives and push the
115 stack frame before doing the call, so that in the event that the call
116 re-enters the RTS the stack is in a sane state.
119 cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
121 First, copy the args into temporaries. We're going to push
122 a return address right before doing the call, so the args
123 must be out of the way.
125 reps_n_amodes <- getArgAmodes stg_args
127 -- Get the *non-void* args, and jiggle them with shimForeignCall
128 arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg)
129 | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
132 arg_tmps <- sequence [ assignTemp arg
133 | (arg, stg_arg) <- arg_exprs]
134 let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args)
136 Now, allocate some result regs.
138 (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty
139 ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
140 emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall
141 arg_hints emptyVarSet{-no live vars-}
143 -- tagToEnum# is special: we need to pull the constructor out of the table,
144 -- and perform an appropriate return.
146 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
147 = ASSERT(isEnumerationTyCon tycon)
148 do { (rep,amode) <- getArgAmode arg
149 ; amode' <- assignTemp amode -- We're going to use it twice,
150 -- so save in a temp if non-trivial
151 ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
152 ; performReturn emitReturnInstr }
154 -- If you're reading this code in the attempt to figure
155 -- out why the compiler panic'ed here, it is probably because
156 -- you used tagToEnum# in a non-monomorphic setting, e.g.,
157 -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
159 tycon = tyConAppTyCon res_ty
162 cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
163 | primOpOutOfLine primop
164 = tailCallPrimOp primop args
166 | ReturnsPrim VoidRep <- result_info
167 = do cgPrimOp [] primop args emptyVarSet
168 performReturn emitReturnInstr
170 | ReturnsPrim rep <- result_info
171 = do res <- newTemp (typeCmmType res_ty)
172 cgPrimOp [res] primop args emptyVarSet
173 performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
175 | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
176 = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
177 cgPrimOp regs primop args emptyVarSet{-no live vars-}
178 returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
180 | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
181 -- c.f. cgExpr (...TagToEnumOp...)
182 = do tag_reg <- newTemp bWord -- The tag is a word
183 cgPrimOp [tag_reg] primop args emptyVarSet
184 stmtC (CmmAssign nodeReg
186 (CmmReg (CmmLocal tag_reg))))
187 performReturn emitReturnInstr
189 result_info = getPrimOpResultInfo primop
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 alt_type alts)
202 = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type 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 = do { -- Figure out what volatile variables to save
231 ; nukeDeadBindings live_in_whole_let
232 ; (save_assts, rhs_eob_info, maybe_cc_slot)
233 <- saveVolatileVarsAndRegs live_in_rhss
235 -- Save those variables right now!
236 ; emitStmts save_assts
238 -- Produce code for the rhss
239 -- and add suitable bindings to the environment
240 ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info
241 maybe_cc_slot bindings
244 ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
248 %********************************************************
252 %********************************************************
254 SCC expressions are treated specially. They set the current cost
258 cgExpr (StgSCC cc expr) = do emitSetCCC cc; cgExpr expr
261 %********************************************************
265 %********************************************************
268 cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
271 %********************************************************
273 %* Non-top-level bindings *
275 %********************************************************
276 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
278 We rely on the support code in @CgCon@ (to do constructors) and
279 in @CgClosure@ (to do closures).
282 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
283 -- the Id is passed along so a binding can be set up
285 cgRhs name (StgRhsCon maybe_cc con args)
286 = do { amodes <- getArgAmodes args
287 ; idinfo <- buildDynCon name maybe_cc con amodes
288 ; returnFC (name, idinfo) }
290 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
291 = setSRT srt $ mkRhsClosure name cc bi 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
315 [the_fv] -- Just one free var
316 upd_flag -- Updatable thunk
318 body@(StgCase (StgApp scrutinee [{-no args-}])
319 _ _ _ srt -- ignore uniq, etc.
321 [(DataAlt con, params, use_mask,
322 (StgApp selectee [{-no args-}]))])
323 | the_fv == scrutinee -- Scrutinee is the only free variable
324 && maybeToBool maybe_offset -- Selectee is a component of the tuple
325 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
326 = -- NOT TRUE: ASSERT(is_single_constructor)
327 -- The simplifier may have statically determined that the single alternative
328 -- is the only possible case and eliminated the others, even if there are
329 -- other constructors in the datatype. It's still ok to make a selector
330 -- thunk in this case, because we *know* which constructor the scrutinee
332 setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
334 lf_info = mkSelectorLFInfo bndr offset_into_int
335 (isUpdatable upd_flag)
336 (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
337 -- Just want the layout
338 maybe_offset = assocMaybe params_w_offsets selectee
339 Just the_offset = maybe_offset
340 offset_into_int = the_offset - fixedHdrSize
346 A more generic AP thunk of the form
348 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
350 A set of these is compiled statically into the RTS, so we just use
351 those. We could extend the idea to thunks where some of the x_i are
352 global ids (and hence not free variables), but this would entail
353 generating a larger thunk. It might be an option for non-optimising
356 We only generate an Ap thunk if all the free variables are pointers,
357 for semi-obvious reasons.
360 mkRhsClosure bndr cc bi
363 [] -- No args; a thunk
364 body@(StgApp fun_id args)
366 | args `lengthIs` (arity-1)
367 && all isFollowableArg (map idCgRep fvs)
368 && isUpdatable upd_flag
369 && arity <= mAX_SPEC_AP_SIZE
372 = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
375 lf_info = mkApLFInfo bndr upd_flag arity
376 -- the payload has to be in the correct order, hence we can't
378 payload = StgVarArg fun_id : args
385 mkRhsClosure bndr cc bi fvs upd_flag args body
386 = cgRhsClosure bndr cc bi fvs upd_flag args body
390 %********************************************************
392 %* Let-no-escape bindings
394 %********************************************************
396 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
397 (StgNonRec binder rhs)
398 = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info
400 NonRecursive binder rhs
401 ; addBindC binder info }
403 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
404 = do { new_bindings <- fixC (\ new_bindings -> do
405 { addBindsC new_bindings
406 ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss
407 rhs_eob_info maybe_cc_slot Recursive b e
408 | (b,e) <- pairs ] })
410 ; addBindsC new_bindings }
412 -- We add the binders to the live-in-rhss set so that we don't
413 -- delete the bindings for the binder from the environment!
414 full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,r) <- pairs])
417 :: StgLiveVars -- Live in rhss
419 -> Maybe VirtualSpOffset
423 -> FCode (Id, CgIdInfo)
425 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
426 (StgRhsClosure cc bi _ upd_flag srt args body)
427 = -- We could check the update flag, but currently we don't switch it off
428 -- for let-no-escaped things, so we omit the check too!
430 -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
431 -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
432 setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
433 maybe_cc_slot rec args body
435 -- For a constructor RHS we want to generate a single chunk of code which
436 -- can be jumped to from many places, which will return the constructor.
437 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
438 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
439 (StgRhsCon cc con args)
440 = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
441 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.
449 newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
450 newUnboxedTupleRegs res_ty =
452 ty_args = tyConAppArgs (repType res_ty)
453 (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
454 let rep = typeCgRep ty,
456 make_new_temp rep = newTemp (argMachRep rep)
458 regs <- mapM make_new_temp reps
459 return (reps,regs,hints)