be94281b49882c100f184769d60f6c154bb2da2c
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreTidy.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section{Tidying up Core}
5
6 \begin{code}
7 module CoreTidy (
8         tidyCorePgm, tidyExpr, 
9         tidyBndr, tidyBndrs
10     ) where
11
12 #include "HsVersions.h"
13
14 import CmdLineOpts      ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
15 import CoreSyn
16 import CoreUnfold       ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreUtils        ( exprArity )
18 import CoreFVs          ( ruleSomeFreeVars, exprSomeFreeVars )
19 import CoreLint         ( showPass, endPass )
20 import VarEnv
21 import VarSet
22 import Var              ( Id, Var )
23 import Id               ( idType, idInfo, idName, isExportedId,
24                           idCafInfo, mkId, isLocalId, isImplicitId,
25                           idFlavour, modifyIdInfo, idArity
26                         ) 
27 import IdInfo           {- loads of stuff -}
28 import Name             ( getOccName, nameOccName, globaliseName, setNameOcc, 
29                           localiseName, mkLocalName, isGlobalName, isDllName
30                         )
31 import OccName          ( TidyOccEnv, initTidyOccEnv, tidyOccName )
32 import Type             ( tidyTopType, tidyType, tidyTyVar )
33 import Module           ( Module, moduleName )
34 import PrimOp           ( PrimOp(..), setCCallUnique )
35 import HscTypes         ( PersistentCompilerState( pcs_PRS ), 
36                           PersistentRenamerState( prsOrig ),
37                           NameSupply( nsNames ), OrigNameCache
38                         )
39 import UniqSupply
40 import DataCon          ( DataCon, dataConName )
41 import Literal          ( isLitLitLit )
42 import FiniteMap        ( lookupFM, addToFM )
43 import Maybes           ( maybeToBool, orElse )
44 import ErrUtils         ( showPass )
45 import SrcLoc           ( noSrcLoc )
46 import UniqFM           ( mapUFM )
47 import Outputable
48 import FastTypes
49 import List             ( partition )
50 import Util             ( mapAccumL )
51 \end{code}
52
53
54
55 %************************************************************************
56 %*                                                                      *
57 \subsection{What goes on}
58 %*                                                                      * 
59 %************************************************************************
60
61 [SLPJ: 19 Nov 00]
62
63 The plan is this.  
64
65 Step 1: Figure out external Ids
66 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
67 First we figure out which Ids are "external" Ids.  An
68 "external" Id is one that is visible from outside the compilation
69 unit.  These are
70         a) the user exported ones
71         b) ones mentioned in the unfoldings, workers, 
72            or rules of externally-visible ones 
73 This exercise takes a sweep of the bindings bottom to top.  Actually,
74 in Step 2 we're also going to need to know which Ids should be
75 exported with their unfoldings, so we produce not an IdSet but an
76 IdEnv Bool
77
78
79 Step 2: Tidy the program
80 ~~~~~~~~~~~~~~~~~~~~~~~~
81 Next we traverse the bindings top to bottom.  For each top-level
82 binder
83
84   - Make all external Ids have Global names and vice versa
85     This is used by the code generator to decide whether
86     to make the label externally visible
87
88   - Give external ids a "tidy" occurrence name.  This means
89     we can print them in interface files without confusing 
90     "x" (unique 5) with "x" (unique 10).
91   
92   - Give external Ids the same Unique as they had before
93     if the name is in the renamer's name cache
94   
95   - Clone all local Ids.  This means that Tidy Core has the property
96     that all Ids are unique, rather than the weaker guarantee of
97     no clashes which the simplifier provides.
98
99   - Give each dynamic CCall occurrence a fresh unique; this is
100     rather like the cloning step above.
101
102   - Give the Id its UTTERLY FINAL IdInfo; in ptic, 
103         * Its flavour becomes ConstantId, reflecting the fact that
104           from now on we regard it as a constant, not local, Id
105
106         * its unfolding, if it should have one
107         
108         * its arity, computed from the number of visible lambdas
109
110         * its CAF info, computed from what is free in its RHS
111
112                 
113 Finally, substitute these new top-level binders consistently
114 throughout, including in unfoldings.  We also tidy binders in
115 RHSs, so that they print nicely in interfaces.
116
117 \begin{code}
118 tidyCorePgm :: DynFlags -> Module
119             -> PersistentCompilerState
120             -> [CoreBind] -> [IdCoreRule]
121             -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
122 tidyCorePgm dflags mod pcs binds_in orphans_in
123   = do  { showPass dflags "Tidy Core"
124
125         ; let ext_ids = findExternalSet binds_in orphans_in
126
127         ; us <- mkSplitUniqSupply 't' -- for "tidy"
128
129         ; let ((us1, orig_env', occ_env, subst_env), binds_out) 
130                         = mapAccumL (tidyTopBind mod ext_ids) 
131                                     (init_tidy_env us) binds_in
132
133         ; let (orphans_out, _) 
134                    = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
135
136         ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
137               pcs' = pcs { pcs_PRS = prs' }
138
139         ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
140
141         ; return (pcs', binds_out, orphans_out)
142         }
143   where
144         -- We also make sure to avoid any exported binders.  Consider
145         --      f{-u1-} = 1     -- Local decl
146         --      ...
147         --      f{-u2-} = 2     -- Exported decl
148         --
149         -- The second exported decl must 'get' the name 'f', so we
150         -- have to put 'f' in the avoids list before we get to the first
151         -- decl.  tidyTopId then does a no-op on exported binders.
152     prs              = pcs_PRS pcs
153     orig             = prsOrig prs
154     orig_env         = nsNames orig
155
156     init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
157     avoids           = [getOccName bndr | bndr <- bindersOfBinds binds_in,
158                                        isGlobalName (idName bndr)]
159 \end{code}
160
161
162 %************************************************************************
163 %*                                                                      *
164 \subsection{Step 1: finding externals}
165 %*                                                                      * 
166 %************************************************************************
167
168 \begin{code}
169 findExternalSet :: [CoreBind] -> [IdCoreRule]
170                 -> IdEnv Bool   -- True <=> show unfolding
171         -- Step 1 from the notes above
172 findExternalSet binds orphan_rules
173   = foldr find init_needed binds
174   where
175     orphan_rule_ids :: IdSet
176     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule 
177                                    | (_, rule) <- orphan_rules]
178     init_needed :: IdEnv Bool
179     init_needed = mapUFM (\_ -> False) orphan_rule_ids
180         -- The mapUFM is a bit cheesy.  It is a cheap way
181         -- to turn the set of orphan_rule_ids, which we use to initialise
182         -- the sweep, into a mapping saying 'don't expose unfolding'    
183         -- (When we come to the binding site we may change our mind, of course.)
184
185     find (NonRec id rhs) needed
186         | need_id needed id = addExternal (id,rhs) needed
187         | otherwise         = needed
188     find (Rec prs) needed   = find_prs prs needed
189
190         -- For a recursive group we have to look for a fixed point
191     find_prs prs needed 
192         | null needed_prs = needed
193         | otherwise       = find_prs other_prs new_needed
194         where
195           (needed_prs, other_prs) = partition (need_pr needed) prs
196           new_needed = foldr addExternal needed needed_prs
197
198         -- The 'needed' set contains the Ids that are needed by earlier
199         -- interface file emissions.  If the Id isn't in this set, and isn't
200         -- exported, there's no need to emit anything
201     need_id needed_set id       = id `elemVarEnv` needed_set || isExportedId id 
202     need_pr needed_set (id,rhs) = need_id needed_set id
203
204 isIdAndLocal id = isId id && isLocalId id
205
206 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
207 -- The Id is needed; extend the needed set
208 -- with it and its dependents (free vars etc)
209 addExternal (id,rhs) needed
210   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
211                  id show_unfold
212   where
213     add_occ id needed = extendVarEnv needed id False
214         -- "False" because we don't know we need the Id's unfolding
215         -- We'll override it later when we find the binding site
216
217     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
218                    | otherwise                = worker_ids      `unionVarSet`
219                                                 unfold_ids      `unionVarSet`
220                                                 spec_ids
221
222     idinfo         = idInfo id
223     dont_inline    = isNeverInlinePrag (inlinePragInfo idinfo)
224     loop_breaker   = isLoopBreaker (occInfo idinfo)
225     bottoming_fn   = isBottomingStrictness (strictnessInfo idinfo)
226     spec_ids       = rulesRhsFreeVars (specInfo idinfo)
227     worker_info    = workerInfo idinfo
228
229         -- Stuff to do with the Id's unfolding
230         -- The simplifier has put an up-to-date unfolding
231         -- in the IdInfo, but the RHS will do just as well
232     unfolding    = unfoldingInfo idinfo
233     rhs_is_small = not (neverUnfold unfolding)
234
235         -- We leave the unfolding there even if there is a worker
236         -- In GHCI the unfolding is used by importers
237         -- When writing an interface file, we omit the unfolding 
238         -- if there is a worker
239     show_unfold = not bottoming_fn       &&     -- Not necessary
240                   not dont_inline        &&
241                   not loop_breaker       &&
242                   rhs_is_small           &&     -- Small enough
243                   okToUnfoldInHiFile rhs        -- No casms etc
244
245     unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
246                | otherwise   = emptyVarSet
247
248     worker_ids = case worker_info of
249                    HasWorker work_id _ -> unitVarSet work_id
250                    otherwise           -> emptyVarSet
251 \end{code}
252
253
254 %************************************************************************
255 %*                                                                      *
256 \subsection{Step 2: top-level tidying}
257 %*                                                                      *
258 %************************************************************************
259
260
261 \begin{code}
262 type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
263
264 -- TopTidyEnv: when tidying we need to know
265 --   * orig_env: Any pre-ordained Names.  These may have arisen because the
266 --        renamer read in an interface file mentioning M.$wf, say,
267 --        and assigned it unique r77.  If, on this compilation, we've
268 --        invented an Id whose name is $wf (but with a different unique)
269 --        we want to rename it to have unique r77, so that we can do easy
270 --        comparisons with stuff from the interface file
271 --
272 --   * occ_env: The TidyOccEnv, which tells us which local occurrences 
273 --     are 'used'
274 --
275 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
276 --
277 --   * uniqsuppy: so we can clone any Ids with non-preordained names.
278 --
279 \end{code}
280
281
282 \begin{code}
283 tidyTopBind :: Module
284             -> IdEnv Bool       -- Domain = Ids that should be external
285                                 -- True <=> their unfolding is external too
286             -> TopTidyEnv -> CoreBind
287             -> (TopTidyEnv, CoreBind)
288
289 tidyTopBind mod ext_ids env (NonRec bndr rhs)
290   = ((us2,orig,occ,subst) , NonRec bndr' rhs')
291   where
292     ((us1,orig,occ,subst), bndr')
293          = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
294     tidy_env    = (occ,subst)
295     caf_info    = hasCafRefs (const True) rhs'
296     (rhs',us2)  = initUs us1 (tidyExpr tidy_env rhs)
297
298 tidyTopBind mod ext_ids env (Rec prs)
299   = (final_env, Rec prs')
300   where
301     (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
302     final_tidy_env = (occ,subst)
303
304     do_one env (bndr,rhs) 
305         = ((us',orig,occ,subst), (bndr',rhs'))
306         where
307         ((us,orig,occ,subst), bndr')
308            = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
309         (rhs', us')   = initUs us (tidyExpr final_tidy_env rhs)
310
311         -- the CafInfo for a recursive group says whether *any* rhs in
312         -- the group may refer indirectly to a CAF (because then, they all do).
313     (bndrs, rhss) = unzip prs'
314     caf_info = hasCafRefss pred rhss
315     pred v = v `notElem` bndrs
316
317
318 tidyTopBinder :: Module -> IdEnv Bool
319               -> TidyEnv -> CoreExpr -> CafInfo
320                         -- The TidyEnv is used to tidy the IdInfo
321                         -- The expr is the already-tided RHS
322                         -- Both are knot-tied: don't look at them!
323               -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
324
325 tidyTopBinder mod ext_ids tidy_env rhs caf_info
326               env@(us, orig_env2, occ_env2, subst_env2) id
327
328   | isImplicitId id     -- Don't mess with constructors, 
329   = (env, id)           -- record selectors, and the like
330
331   | otherwise
332         -- This function is the heart of Step 2
333         -- The second env is the one to use for the IdInfo
334         -- It's necessary because when we are dealing with a recursive
335         -- group, a variable late in the group might be mentioned
336         -- in the IdInfo of one early in the group
337
338         -- The rhs is already tidied
339         
340   = ((us_r, orig_env', occ_env', subst_env'), id')
341   where
342     (us_l, us_r)    = splitUniqSupply us
343
344     (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
345                                                is_external
346                                                (idName id)
347     ty'             = tidyTopType (idType id)
348     idinfo'         = tidyIdInfo us_l tidy_env
349                          is_external unfold_info arity_info caf_info id
350
351     id'        = mkId name' ty' idinfo'
352     subst_env' = extendVarEnv subst_env2 id id'
353
354     maybe_external = lookupVarEnv ext_ids id
355     is_external    = maybeToBool maybe_external
356
357     -- Expose an unfolding if ext_ids tells us to
358     show_unfold = maybe_external `orElse` False
359     unfold_info | show_unfold = mkTopUnfolding rhs
360                 | otherwise   = noUnfolding
361
362     arity_info = exprArity rhs
363
364
365 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
366   | opt_OmitInterfacePragmas || not is_external
367         -- No IdInfo if the Id isn't external, or if we don't have -O
368   = mkIdInfo new_flavour caf_info
369         `setStrictnessInfo` strictnessInfo core_idinfo
370         `setArityInfo`      ArityExactly arity_info
371         -- Keep strictness, arity and CAF info; it's used by the code generator
372
373   | otherwise
374   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
375      in
376      mkIdInfo new_flavour caf_info
377         `setCprInfo`        cprInfo core_idinfo
378         `setStrictnessInfo` strictnessInfo core_idinfo
379         `setInlinePragInfo` inlinePragInfo core_idinfo
380         `setUnfoldingInfo`  unfold_info
381         `setWorkerInfo`     tidyWorker tidy_env arity_info (workerInfo core_idinfo)
382         `setSpecInfo`       rules'
383         `setArityInfo`      ArityExactly arity_info
384                 -- this is the final IdInfo, it must agree with the
385                 -- code finally generated (i.e. NO more transformations
386                 -- after this!).
387   where
388     core_idinfo = idInfo id
389
390         -- A DFunId must stay a DFunId, so that we can gather the
391         -- DFunIds up later.  Other local things become ConstantIds.
392     new_flavour = case flavourInfo core_idinfo of
393                     VanillaId  -> ConstantId
394                     ExportedId -> ConstantId
395                     ConstantId -> ConstantId    -- e.g. Default methods
396                     DictFunId  -> DictFunId
397                     flavour    -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
398                                   flavour
399
400
401 -- This is where we set names to local/global based on whether they really are 
402 -- externally visible (see comment at the top of this module).  If the name
403 -- was previously local, we have to give it a unique occurrence name if
404 -- we intend to globalise it.
405 tidyTopName mod orig_env occ_env external name
406   | global && internal = (orig_env, occ_env, localiseName name)
407
408   | local  && internal = (orig_env, occ_env', setNameOcc name occ')
409         -- Even local, internal names must get a unique occurrence, because
410         -- if we do -split-objs we globalise the name later, n the code generator
411
412   | global && external = (orig_env, occ_env, name)
413         -- Global names are assumed to have been allocated by the renamer,
414         -- so they already have the "right" unique
415
416   | local  && external = case lookupFM orig_env key of
417                            Just orig -> (orig_env,                         occ_env', orig)
418                            Nothing   -> (addToFM orig_env key global_name, occ_env', global_name)
419         -- If we want to globalise a currently-local name, check
420         -- whether we have already assigned a unique for it.
421         -- If so, use it; if not, extend the table
422
423   where
424     (occ_env', occ') = tidyOccName occ_env (nameOccName name)
425     key              = (moduleName mod, occ')
426     global_name      = globaliseName (setNameOcc name occ') mod
427     global           = isGlobalName name
428     local            = not global
429     internal         = not external
430
431 ------------  Worker  --------------
432 -- We only treat a function as having a worker if
433 -- the exported arity (which is now the number of visible lambdas)
434 -- is the same as the arity at the moment of the w/w split
435 -- If so, we can safely omit the unfolding inside the wrapper, and
436 -- instead re-generate it from the type/arity/strictness info
437 -- But if the arity has changed, we just take the simple path and
438 -- put the unfolding into the interface file, forgetting the fact
439 -- that it's a wrapper.  
440 --
441 -- How can this happen?  Sometimes we get
442 --      f = coerce t (\x y -> $wf x y)
443 -- at the moment of w/w split; but the eta reducer turns it into
444 --      f = coerce t $wf
445 -- which is perfectly fine except that the exposed arity so far as
446 -- the code generator is concerned (zero) differs from the arity
447 -- when we did the split (2).  
448 --
449 -- All this arises because we use 'arity' to mean "exactly how many
450 -- top level lambdas are there" in interface files; but during the
451 -- compilation of this module it means "how many things can I apply
452 -- this to".
453 tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity) 
454   | real_arity == wrap_arity
455   = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
456 tidyWorker tidy_env real_arity other
457   = NoWorker
458
459 ------------  Rules  --------------
460 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
461 tidyIdRules env [] = returnUs []
462 tidyIdRules env ((fn,rule) : rules)
463   = tidyRule env rule           `thenUs` \ rule ->
464     tidyIdRules env rules       `thenUs` \ rules ->
465     returnUs ((tidyVarOcc env fn, rule) : rules)
466
467 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
468 tidyRules env (Rules rules fvs) 
469   = mapUs (tidyRule env) rules          `thenUs` \ rules ->
470     returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
471   where
472     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
473
474 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
475 tidyRule env rule@(BuiltinRule _) = returnUs rule
476 tidyRule env (Rule name vars tpl_args rhs)
477   = tidyBndrs env vars                  `thenUs` \ (env', vars) ->
478     mapUs (tidyExpr env') tpl_args      `thenUs` \ tpl_args ->
479     tidyExpr env' rhs                   `thenUs` \ rhs ->
480     returnUs (Rule name vars tpl_args rhs)
481 \end{code}
482
483 %************************************************************************
484 %*                                                                      *
485 \subsection{Step 2: inner tidying
486 %*                                                                      *
487 %************************************************************************
488
489 \begin{code}
490 tidyBind :: TidyEnv
491          -> CoreBind
492          -> UniqSM (TidyEnv, CoreBind)
493 tidyBind env (NonRec bndr rhs)
494   = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
495     tidyExpr env' rhs              `thenUs` \ rhs' ->
496     returnUs (env', NonRec bndr' rhs')
497
498 tidyBind env (Rec prs)
499   = mapAccumLUs tidyBndrWithRhs env prs         `thenUs` \ (env', bndrs') ->
500     mapUs (tidyExpr env') (map snd prs)         `thenUs` \ rhss' ->
501     returnUs (env', Rec (zip bndrs' rhss'))
502
503 tidyExpr env (Var v)   
504   = fiddleCCall v  `thenUs` \ v ->
505     returnUs (Var (tidyVarOcc env v))
506
507 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
508 tidyExpr env (Lit lit) = returnUs (Lit lit)
509
510 tidyExpr env (App f a)
511   = tidyExpr env f              `thenUs` \ f ->
512     tidyExpr env a              `thenUs` \ a ->
513     returnUs (App f a)
514
515 tidyExpr env (Note n e)
516   = tidyExpr env e              `thenUs` \ e ->
517     returnUs (Note (tidyNote env n) e)
518
519 tidyExpr env (Let b e) 
520   = tidyBind env b              `thenUs` \ (env', b') ->
521     tidyExpr env' e             `thenUs` \ e ->
522     returnUs (Let b' e)
523
524 tidyExpr env (Case e b alts)
525   = tidyExpr env e              `thenUs` \ e ->
526     tidyBndr env b              `thenUs` \ (env', b) ->
527     mapUs (tidyAlt env') alts   `thenUs` \ alts ->
528     returnUs (Case e b alts)
529
530 tidyExpr env (Lam b e)
531   = tidyBndr env b              `thenUs` \ (env', b) ->
532     tidyExpr env' e             `thenUs` \ e ->
533     returnUs (Lam b e)
534
535
536 tidyAlt env (con, vs, rhs)
537   = tidyBndrs env vs            `thenUs` \ (env', vs) ->
538     tidyExpr env' rhs           `thenUs` \ rhs ->
539     returnUs (con, vs, rhs)
540
541 tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
542 tidyNote env note            = note
543 \end{code}
544
545
546 %************************************************************************
547 %*                                                                      *
548 \subsection{Tidying up non-top-level binders}
549 %*                                                                      *
550 %************************************************************************
551
552 \begin{code}
553 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
554                                   Just v' -> v'
555                                   Nothing -> v
556
557 -- tidyBndr is used for lambda and case binders
558 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
559 tidyBndr env var
560   | isTyVar var = returnUs (tidyTyVar env var)
561   | otherwise   = tidyId env var vanillaIdInfo
562
563 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
564 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
565
566 -- tidyBndrWithRhs is used for let binders
567 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
568 tidyBndrWithRhs env (id,rhs)
569    = tidyId env id idinfo
570    where
571         idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
572                         -- NB: This throws away the IdInfo of the Id, which we
573                         -- no longer need.  That means we don't need to
574                         -- run over it with env, nor renumber it.
575
576 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
577 tidyId env@(tidy_env, var_env) id idinfo
578   =     -- Non-top-level variables
579     getUniqueUs   `thenUs` \ uniq ->
580     let 
581         -- Give the Id a fresh print-name, *and* rename its type
582         -- The SrcLoc isn't important now, 
583         -- though we could extract it from the Id
584         name'             = mkLocalName uniq occ' noSrcLoc
585         (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
586         ty'               = tidyType (tidy_env,var_env) (idType id)
587         id'               = mkId name' ty' idinfo
588         var_env'          = extendVarEnv var_env id id'
589     in
590     returnUs ((tidy_env', var_env'), id')
591
592
593 fiddleCCall id 
594   = case idFlavour id of
595          PrimOpId (CCallOp ccall) ->
596             -- Make a guaranteed unique name for a dynamic ccall.
597             getUniqueUs         `thenUs` \ uniq ->
598             returnUs (modifyIdInfo (`setFlavourInfo` 
599                             PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
600          other_flavour ->
601              returnUs id
602 \end{code}
603
604 %************************************************************************
605 %*                                                                      *
606 \subsection{Figuring out CafInfo for an expression}
607 %*                                                                      *
608 %************************************************************************
609
610 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
611 We mark such things as `MayHaveCafRefs' because this information is
612 used to decide whether a particular closure needs to be referenced
613 in an SRT or not.
614
615 There are two reasons for setting MayHaveCafRefs:
616         a) The RHS is a CAF: a top-level updatable thunk.
617         b) The RHS refers to something that MayHaveCafRefs
618
619 Possible improvement: In an effort to keep the number of CAFs (and 
620 hence the size of the SRTs) down, we could also look at the expression and 
621 decide whether it requires a small bounded amount of heap, so we can ignore 
622 it as a CAF.  In these cases however, we would need to use an additional
623 CAF list to keep track of non-collectable CAFs.  
624
625 \begin{code}
626 hasCafRefs  :: (Id -> Bool) -> CoreExpr -> CafInfo
627 -- Only called for the RHS of top-level lets
628 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
629         -- predicate returns True for a given Id if we look at this Id when
630         -- calculating the result.  Used to *avoid* looking at the CafInfo
631         -- field for an Id that is part of the current recursive group.
632
633 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
634                         then MayHaveCafRefs
635                         else NoCafRefs
636
637         -- used for recursive groups.  The whole group is set to
638         -- "MayHaveCafRefs" if at least one of the group is a CAF or
639         -- refers to any CAFs.
640 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
641                         then MayHaveCafRefs
642                         else NoCafRefs
643
644 cafRefs p (Var id)
645  | p id
646  = case idCafInfo id of 
647         NoCafRefs      -> fastBool False
648         MayHaveCafRefs -> fastBool True
649  | otherwise
650  = fastBool False
651
652 cafRefs p (Lit l)            = fastBool False
653 cafRefs p (App f a)          = cafRefs p f `fastOr` cafRefs p a
654 cafRefs p (Lam x e)          = cafRefs p e
655 cafRefs p (Let b e)          = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
656 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
657 cafRefs p (Note n e)         = cafRefs p e
658 cafRefs p (Type t)           = fastBool False
659
660 cafRefss p []     = fastBool False
661 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
662
663
664 isCAF :: CoreExpr -> Bool
665 -- Only called for the RHS of top-level lets
666 isCAF e = not (rhsIsNonUpd e)
667   {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
668
669 rhsIsNonUpd :: CoreExpr -> Bool
670   -- True => Value-lambda, constructor, PAP
671   -- This is a bit like CoreUtils.exprIsValue, with the following differences:
672   --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
673   --
674   --    b) (C x xs), where C is a contructors is updatable if the application is
675   --       dynamic: see isDynConApp
676   -- 
677   --    c) don't look through unfolding of f in (f x).  I'm suspicious of this one
678
679 rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
680 rhsIsNonUpd (Note (SCC _) e)   = False
681 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
682 rhsIsNonUpd other_expr
683   = go other_expr 0 []
684   where
685     go (Var f) n_args args = idAppIsNonUpd f n_args args
686         
687     go (App f a) n_args args
688         | isTypeArg a = go f n_args args
689         | otherwise   = go f (n_args + 1) (a:args)
690
691     go (Note (SCC _) f) n_args args = False
692     go (Note _ f) n_args args       = go f n_args args
693
694     go other n_args args = False
695
696 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
697 idAppIsNonUpd id n_val_args args
698   = case idFlavour id of
699         DataConId con | not (isDynConApp con args) -> True
700         other -> n_val_args < idArity id
701
702 isDynConApp :: DataCon -> [CoreExpr] -> Bool
703 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
704 -- Top-level constructor applications can usually be allocated 
705 -- statically, but they can't if 
706 --      a) the constructor, or any of the arguments, come from another DLL
707 --      b) any of the arguments are LitLits
708 -- (because we can't refer to static labels in other DLLs).
709 -- If this happens we simply make the RHS into an updatable thunk, 
710 -- and 'exectute' it rather than allocating it statically.
711 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
712
713
714 isDynArg :: CoreExpr -> Bool
715 isDynArg (Var v)    = isDllName (idName v)
716 isDynArg (Note _ e) = isDynArg e
717 isDynArg (Lit lit)  = isLitLitLit lit
718 isDynArg (App e _)  = isDynArg e        -- must be a type app
719 isDynArg (Lam _ e)  = isDynArg e        -- must be a type lam
720 \end{code}