Some alpha renaming
[ghc.git] / compiler / codeGen / CgExpr.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module CgExpr ( cgExpr ) where
15
16 #include "HsVersions.h"
17
18 import StgSyn
19 import CgMonad
20
21 import CostCentre
22 import SMRep
23 import CoreSyn
24 import CgProf
25 import CgHeapery
26 import CgBindery
27 import CgCase
28 import CgClosure
29 import CgCon
30 import CgLetNoEscape
31 import CgTailCall
32 import CgInfoTbls
33 import CgForeignCall
34 import CgPrimOp
35 import CgHpc
36 import CgUtils
37 import ClosureInfo
38 import OldCmm
39 import OldCmmUtils
40 import VarSet
41 import Literal
42 import PrimOp
43 import Id
44 import TyCon
45 import Type
46 import Maybes
47 import ListSetOps
48 import BasicTypes
49 import Util
50 import DynFlags
51 import Outputable
52 \end{code}
53
54 This module provides the support code for @StgToAbstractC@ to deal
55 with STG {\em expressions}.  See also @CgClosure@, which deals
56 with closures, and @CgCon@, which deals with constructors.
57
58 \begin{code}
59 cgExpr  :: StgExpr              -- input
60         -> Code                 -- output
61 \end{code}
62
63 %********************************************************
64 %*                                                      *
65 %*              Tail calls                              *
66 %*                                                      *
67 %********************************************************
68
69 ``Applications'' mean {\em tail calls}, a service provided by module
70 @CgTailCall@.  This includes literals, which show up as
71 @(STGApp (StgLitArg 42) [])@.
72
73 \begin{code}
74 cgExpr (StgApp fun args) = cgTailCall fun args
75 \end{code}
76
77 %********************************************************
78 %*                                                      *
79 %*              STG ConApps  (for inline versions)      *
80 %*                                                      *
81 %********************************************************
82
83 \begin{code}
84 cgExpr (StgConApp con args)
85   = do  { amodes <- getArgAmodes args
86         ; cgReturnDataCon con amodes }
87 \end{code}
88
89 Literals are similar to constructors; they return by putting
90 themselves in an appropriate register and returning to the address on
91 top of the stack.
92
93 \begin{code}
94 cgExpr (StgLit lit)
95   = do  { cmm_lit <- cgLit lit
96         ; performPrimReturn rep (CmmLit cmm_lit) }
97   where
98     rep = (typeCgRep) (literalType lit)
99 \end{code}
100
101
102 %********************************************************
103 %*                                                      *
104 %*      PrimOps and foreign calls.
105 %*                                                      *
106 %********************************************************
107
108 NOTE about "safe" foreign calls: a safe foreign call is never compiled
109 inline in a case expression.  When we see
110
111         case (ccall ...) of { ... }
112
113 We generate a proper return address for the alternatives and push the
114 stack frame before doing the call, so that in the event that the call
115 re-enters the RTS the stack is in a sane state.
116
117 \begin{code}
118 cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
119     dflags <- getDynFlags
120     {-
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.
124     -}
125     reps_n_amodes <- getArgAmodes stg_args
126     let 
127         -- Get the *non-void* args, and jiggle them with shimForeignCall
128         arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg)
129                     | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
130                       nonVoidArg rep]
131
132     arg_tmps <- sequence [ assignTemp arg
133                          | (arg, _) <- arg_exprs]
134     let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args)
135     {-
136         Now, allocate some result regs.
137     -}
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-}
142       
143 -- tagToEnum# is special: we need to pull the constructor out of the table,
144 -- and perform an appropriate return.
145
146 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) 
147   = ASSERT(isEnumerationTyCon tycon)
148     do  { dflags <- getDynFlags
149         ; (_rep,amode) <- getArgAmode arg
150         ; amode' <- assignTemp amode    -- We're going to use it twice,
151                                         -- so save in a temp if non-trivial
152         ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode'))
153         ; performReturn $ emitReturnInstr (Just [node]) }
154    where
155           -- If you're reading this code in the attempt to figure
156           -- out why the compiler panic'ed here, it is probably because
157           -- you used tagToEnum# in a non-monomorphic setting, e.g., 
158           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
159           -- That won't work.
160         tycon = tyConAppTyCon res_ty
161
162
163 cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty)
164   = cgTailCall a []
165   -- seq# :: a -> State# -> (# State# , a #)
166   -- but the return convention for (# State#, a #) is exactly the same as
167   -- for just a, so we can implment seq# by
168   --   seq# a s  ==>  a
169
170 cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
171   | primOpOutOfLine primop
172         = tailCallPrimOp primop args
173
174   | ReturnsPrim VoidRep <- result_info
175         = do cgPrimOp [] primop args emptyVarSet
176              -- ToDo: STG Live -- worried about this
177              performReturn $ emitReturnInstr (Just [])
178
179   | ReturnsPrim rep <- result_info
180         = do dflags <- getDynFlags
181              res <- newTemp (typeCmmType dflags res_ty)
182              cgPrimOp [res] primop args emptyVarSet
183              performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
184
185   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
186         = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
187              cgPrimOp regs primop args emptyVarSet{-no live vars-}
188              returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
189
190   | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
191         -- c.f. cgExpr (...TagToEnumOp...)
192         = do dflags <- getDynFlags
193              tag_reg <- newTemp (bWord dflags) -- The tag is a word
194              cgPrimOp [tag_reg] primop args emptyVarSet
195              stmtC (CmmAssign nodeReg
196                     (tagToClosure dflags tycon
197                      (CmmReg (CmmLocal tag_reg))))
198              -- ToDo: STG Live -- worried about this
199              performReturn $ emitReturnInstr (Just [node])
200   where
201         result_info = getPrimOpResultInfo primop
202
203 cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty)
204   = tailCallPrimCall primcall args
205 \end{code}
206
207 %********************************************************
208 %*                                                      *
209 %*              Case expressions                        *
210 %*                                                      *
211 %********************************************************
212 Case-expression conversion is complicated enough to have its own
213 module, @CgCase@.
214 \begin{code}
215
216 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
217   = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts
218 \end{code}
219
220
221 %********************************************************
222 %*                                                      *
223 %*              Let and letrec                          *
224 %*                                                      *
225 %********************************************************
226 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
227
228 \begin{code}
229 cgExpr (StgLet (StgNonRec name rhs) expr)
230   = cgRhs name rhs      `thenFC` \ (name, info) ->
231     addBindC name info  `thenC`
232     cgExpr expr
233
234 cgExpr (StgLet (StgRec pairs) expr)
235   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
236                             listFCs [ cgRhs b e | (b,e) <- pairs ]
237     ) `thenFC` \ new_bindings ->
238
239     addBindsC new_bindings `thenC`
240     cgExpr expr
241 \end{code}
242
243 \begin{code}
244 cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
245   = do  {       -- Figure out what volatile variables to save
246         ; nukeDeadBindings live_in_whole_let
247         ; (save_assts, rhs_eob_info, maybe_cc_slot) 
248                 <- saveVolatileVarsAndRegs live_in_rhss
249
250         -- Save those variables right now!
251         ; emitStmts save_assts
252
253         -- Produce code for the rhss
254         -- and add suitable bindings to the environment
255         ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info 
256                                 maybe_cc_slot bindings
257
258         -- Do the body
259         ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
260 \end{code}
261
262
263 %********************************************************
264 %*                                                      *
265 %*              SCC Expressions                         *
266 %*                                                      *
267 %********************************************************
268
269 SCC expressions are treated specially. They set the current cost
270 centre.
271
272 \begin{code}
273 cgExpr (StgSCC cc tick push expr) = do emitSetCCC cc tick push; cgExpr expr
274 \end{code}
275
276 %********************************************************
277 %*                                                     *
278 %*             Hpc Tick Boxes                          *
279 %*                                                     *
280 %********************************************************
281
282 \begin{code}
283 cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
284 \end{code}
285
286 %********************************************************
287 %*                                                     *
288 %*             Anything else                           *
289 %*                                                     *
290 %********************************************************
291
292 \begin{code}
293 cgExpr _ = panic "cgExpr"
294 \end{code}
295
296 %********************************************************
297 %*                                                      *
298 %*              Non-top-level bindings                  *
299 %*                                                      *
300 %********************************************************
301 \subsection[non-top-level-bindings]{Converting non-top-level bindings}
302
303 We rely on the support code in @CgCon@ (to do constructors) and
304 in @CgClosure@ (to do closures).
305
306 \begin{code}
307 cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
308         -- the Id is passed along so a binding can be set up
309
310 cgRhs name (StgRhsCon maybe_cc con args)
311   = do  { amodes <- getArgAmodes args
312         ; idinfo <- buildDynCon name maybe_cc con amodes
313         ; returnFC (name, idinfo) }
314
315 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
316   = do dflags <- getDynFlags
317        setSRT srt $ mkRhsClosure dflags name cc bi fvs upd_flag args body
318 \end{code}
319
320 mkRhsClosure looks for two special forms of the right-hand side:
321         a) selector thunks.
322         b) AP thunks
323
324 If neither happens, it just calls mkClosureLFInfo.  You might think
325 that mkClosureLFInfo should do all this, but it seems wrong for the
326 latter to look at the structure of an expression
327
328 Selectors
329 ~~~~~~~~~
330 We look at the body of the closure to see if it's a selector---turgid,
331 but nothing deep.  We are looking for a closure of {\em exactly} the
332 form:
333
334 ...  = [the_fv] \ u [] ->
335          case the_fv of
336            con a_1 ... a_n -> a_i
337
338
339 \begin{code}
340 mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
341              -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id
342              -> FCode (Id, CgIdInfo)
343 mkRhsClosure    dflags bndr cc bi
344                 [the_fv]                -- Just one free var
345                 upd_flag                -- Updatable thunk
346                 []                      -- A thunk
347                 body@(StgCase (StgApp scrutinee [{-no args-}])
348                       _ _ _ srt   -- ignore uniq, etc.
349                       (AlgAlt _)
350                       [(DataAlt con, params, _use_mask,
351                             (StgApp selectee [{-no args-}]))])
352   |  the_fv == scrutinee                -- Scrutinee is the only free variable
353   && maybeToBool maybe_offset           -- Selectee is a component of the tuple
354   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
355   = -- NOT TRUE: ASSERT(is_single_constructor)
356     -- The simplifier may have statically determined that the single alternative
357     -- is the only possible case and eliminated the others, even if there are
358     -- other constructors in the datatype.  It's still ok to make a selector
359     -- thunk in this case, because we *know* which constructor the scrutinee
360     -- will evaluate to.
361     setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
362   where
363     lf_info               = mkSelectorLFInfo bndr offset_into_int
364                                  (isUpdatable upd_flag)
365     (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params)
366                         -- Just want the layout
367     maybe_offset          = assocMaybe params_w_offsets selectee
368     Just the_offset       = maybe_offset
369     offset_into_int       = the_offset - fixedHdrSize dflags
370 \end{code}
371
372 Ap thunks
373 ~~~~~~~~~
374
375 A more generic AP thunk of the form
376
377         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
378
379 A set of these is compiled statically into the RTS, so we just use
380 those.  We could extend the idea to thunks where some of the x_i are
381 global ids (and hence not free variables), but this would entail
382 generating a larger thunk.  It might be an option for non-optimising
383 compilation, though.
384
385 We only generate an Ap thunk if all the free variables are pointers,
386 for semi-obvious reasons.
387
388 \begin{code}
389 mkRhsClosure dflags bndr cc bi
390                 fvs
391                 upd_flag
392                 []                      -- No args; a thunk
393                 body@(StgApp fun_id args)
394
395   | args `lengthIs` (arity-1)
396         && all isFollowableArg (map idCgRep fvs) 
397         && isUpdatable upd_flag
398         && arity <= mAX_SPEC_AP_SIZE dflags
399         && not (gopt Opt_SccProfilingOn dflags)
400                                   -- not when profiling: we don't want to
401                                   -- lose information about this particular
402                                   -- thunk (e.g. its type) (#949)
403
404                    -- Ha! an Ap thunk
405         = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
406
407    where
408         lf_info = mkApLFInfo bndr upd_flag arity
409         -- the payload has to be in the correct order, hence we can't
410         -- just use the fvs.
411         payload = StgVarArg fun_id : args
412         arity   = length fvs
413 \end{code}
414
415 The default case
416 ~~~~~~~~~~~~~~~~
417 \begin{code}
418 mkRhsClosure _ bndr cc bi fvs upd_flag args body
419   = cgRhsClosure bndr cc bi fvs upd_flag args body
420 \end{code}
421
422
423 %********************************************************
424 %*                                                      *
425 %*              Let-no-escape bindings
426 %*                                                      *
427 %********************************************************
428 \begin{code}
429 cgLetNoEscapeBindings :: StgLiveVars -> EndOfBlockInfo
430                       -> Maybe VirtualSpOffset -> GenStgBinding Id Id
431                       -> Code
432 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot 
433         (StgNonRec binder rhs)
434   = do  { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info 
435                                             maybe_cc_slot       
436                                             NonRecursive binder rhs 
437         ; addBindC binder info }
438
439 cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
440   = do  { new_bindings <- fixC (\ new_bindings -> do
441                 { addBindsC new_bindings
442                 ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss 
443                                 rhs_eob_info maybe_cc_slot Recursive b e 
444                           | (b,e) <- pairs ] })
445
446         ; addBindsC new_bindings }
447   where
448     -- We add the binders to the live-in-rhss set so that we don't
449     -- delete the bindings for the binder from the environment!
450     full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,_) <- pairs])
451
452 cgLetNoEscapeRhs
453     :: StgLiveVars      -- Live in rhss
454     -> EndOfBlockInfo
455     -> Maybe VirtualSpOffset
456     -> RecFlag
457     -> Id
458     -> StgRhs
459     -> FCode (Id, CgIdInfo)
460
461 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
462                  (StgRhsClosure cc bi _ _upd_flag srt args body)
463   = -- We could check the update flag, but currently we don't switch it off
464     -- for let-no-escaped things, so we omit the check too!
465     -- case upd_flag of
466     --     Updatable -> panic "cgLetNoEscapeRhs"        -- Nothing to update!
467     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
468     setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
469         maybe_cc_slot rec args body
470
471 -- For a constructor RHS we want to generate a single chunk of code which
472 -- can be jumped to from many places, which will return the constructor.
473 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
474 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
475                  (StgRhsCon cc con args)
476   = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
477                          full_live_in_rhss rhs_eob_info maybe_cc_slot rec
478         []      --No args; the binder is data structure, not a function
479         (StgConApp con args)
480 \end{code}
481
482 Little helper for primitives that return unboxed tuples.
483
484 \begin{code}
485 newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
486 newUnboxedTupleRegs res_ty = do
487    dflags <- getDynFlags
488    let
489         UbxTupleRep ty_args = repType res_ty
490         (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
491                                                     let rep = typeCgRep ty,
492                                                     nonVoidArg rep ]
493         make_new_temp rep = newTemp (argMachRep dflags rep)
494    regs <- mapM make_new_temp reps
495    return (reps,regs,hints)
496 \end{code}