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