Make Core Lint check for locally-bound GlobalIds
[ghc.git] / compiler / deSugar / Desugar.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 The Desugarer: turning HsSyn into Core.
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module Desugar ( deSugar, deSugarExpr ) where
12
13 import DynFlags
14 import HscTypes
15 import HsSyn
16 import TcRnTypes
17 import TcRnMonad ( finalSafeMode )
18 import MkIface
19 import Id
20 import Name
21 import Type
22 import FamInstEnv
23 import Coercion
24 import InstEnv
25 import Class
26 import Avail
27 import PatSyn
28 import CoreSyn
29 import CoreSubst
30 import PprCore
31 import DsMonad
32 import DsExpr
33 import DsBinds
34 import DsForeign
35 import Module
36 import NameSet
37 import NameEnv
38 import Rules
39 import TysPrim (eqReprPrimTyCon)
40 import TysWiredIn (coercibleTyCon )
41 import BasicTypes ( Activation(.. ) )
42 import CoreMonad ( CoreToDo(..) )
43 import CoreLint ( endPassIO )
44 import MkCore
45 import FastString
46 import ErrUtils
47 import Outputable
48 import SrcLoc
49 import Coverage
50 import Util
51 import MonadUtils
52 import OrdList
53 import StaticPtrTable
54 import Data.List
55 import Data.IORef
56 import Control.Monad( when )
57
58 {-
59 ************************************************************************
60 * *
61 * The main function: deSugar
62 * *
63 ************************************************************************
64 -}
65
66 -- | Main entry point to the desugarer.
67 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
68 -- Can modify PCS by faulting in more declarations
69
70 deSugar hsc_env
71 mod_loc
72 tcg_env@(TcGblEnv { tcg_mod = mod,
73 tcg_src = hsc_src,
74 tcg_type_env = type_env,
75 tcg_imports = imports,
76 tcg_exports = exports,
77 tcg_keep = keep_var,
78 tcg_th_splice_used = tc_splice_used,
79 tcg_rdr_env = rdr_env,
80 tcg_fix_env = fix_env,
81 tcg_inst_env = inst_env,
82 tcg_fam_inst_env = fam_inst_env,
83 tcg_warns = warns,
84 tcg_anns = anns,
85 tcg_binds = binds,
86 tcg_imp_specs = imp_specs,
87 tcg_dependent_files = dependent_files,
88 tcg_ev_binds = ev_binds,
89 tcg_fords = fords,
90 tcg_rules = rules,
91 tcg_vects = vects,
92 tcg_patsyns = patsyns,
93 tcg_tcs = tcs,
94 tcg_insts = insts,
95 tcg_fam_insts = fam_insts,
96 tcg_hpc = other_hpc_info})
97
98 = do { let dflags = hsc_dflags hsc_env
99 print_unqual = mkPrintUnqualified dflags rdr_env
100 ; showPass dflags "Desugar"
101
102 -- Desugar the program
103 ; let export_set = availsToNameSet exports
104 target = hscTarget dflags
105 hpcInfo = emptyHpcInfo other_hpc_info
106 want_ticks = gopt Opt_Hpc dflags
107 || target == HscInterpreted
108 || (gopt Opt_SccProfilingOn dflags
109 && case profAuto dflags of
110 NoProfAuto -> False
111 _ -> True)
112
113 ; (binds_cvr, ds_hpc_info, modBreaks)
114 <- if want_ticks && not (isHsBootOrSig hsc_src)
115 then addTicksToBinds dflags mod mod_loc export_set
116 (typeEnvTyCons type_env) binds
117 else return (binds, hpcInfo, emptyModBreaks)
118
119 ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
120 do { ds_ev_binds <- dsEvBinds ev_binds
121 ; core_prs <- dsTopLHsBinds binds_cvr
122 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
123 ; (ds_fords, foreign_prs) <- dsForeigns fords
124 ; ds_rules <- mapMaybeM dsRule rules
125 ; ds_vects <- mapM dsVect vects
126 ; stBinds <- dsGetStaticBindsVar >>=
127 liftIO . readIORef
128 ; let hpc_init
129 | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
130 | otherwise = empty
131 -- Stub to insert the static entries of the
132 -- module into the static pointer table
133 spt_init = sptInitCode mod stBinds
134 ; return ( ds_ev_binds
135 , foreign_prs `appOL` core_prs `appOL` spec_prs
136 `appOL` toOL (map snd stBinds)
137 , spec_rules ++ ds_rules, ds_vects
138 , ds_fords `appendStubC` hpc_init
139 `appendStubC` spt_init) }
140
141 ; case mb_res of {
142 Nothing -> return (msgs, Nothing) ;
143 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
144
145 do { -- Add export flags to bindings
146 keep_alive <- readIORef keep_var
147 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
148 final_prs = addExportFlagsAndRules target export_set keep_alive
149 rules_for_locals (fromOL all_prs)
150
151 final_pgm = combineEvBinds ds_ev_binds final_prs
152 -- Notice that we put the whole lot in a big Rec, even the foreign binds
153 -- When compiling PrelFloat, which defines data Float = F# Float#
154 -- we want F# to be in scope in the foreign marshalling code!
155 -- You might think it doesn't matter, but the simplifier brings all top-level
156 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
157
158 #ifdef DEBUG
159 -- Debug only as pre-simple-optimisation program may be really big
160 ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
161 #endif
162 ; (ds_binds, ds_rules_for_imps, ds_vects)
163 <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
164 -- The simpleOptPgm gets rid of type
165 -- bindings plus any stupid dead code
166
167 ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
168
169 ; let used_names = mkUsedNames tcg_env
170 ; deps <- mkDependencies tcg_env
171
172 ; used_th <- readIORef tc_splice_used
173 ; dep_files <- readIORef dependent_files
174 ; safe_mode <- finalSafeMode dflags tcg_env
175
176 ; let mod_guts = ModGuts {
177 mg_module = mod,
178 mg_boot = hsc_src == HsBootFile,
179 mg_exports = exports,
180 mg_deps = deps,
181 mg_used_names = used_names,
182 mg_used_th = used_th,
183 mg_dir_imps = imp_mods imports,
184 mg_rdr_env = rdr_env,
185 mg_fix_env = fix_env,
186 mg_warns = warns,
187 mg_anns = anns,
188 mg_tcs = tcs,
189 mg_insts = insts,
190 mg_fam_insts = fam_insts,
191 mg_inst_env = inst_env,
192 mg_fam_inst_env = fam_inst_env,
193 mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
194 mg_rules = ds_rules_for_imps,
195 mg_binds = ds_binds,
196 mg_foreign = ds_fords,
197 mg_hpc_info = ds_hpc_info,
198 mg_modBreaks = modBreaks,
199 mg_vect_decls = ds_vects,
200 mg_vect_info = noVectInfo,
201 mg_safe_haskell = safe_mode,
202 mg_trust_pkg = imp_trust_own_pkg imports,
203 mg_dependent_files = dep_files
204 }
205 ; return (msgs, Just mod_guts)
206 }}}
207
208 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
209 dsImpSpecs imp_specs
210 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
211 ; let (spec_binds, spec_rules) = unzip spec_prs
212 ; return (concatOL spec_binds, spec_rules) }
213
214 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
215 -- Top-level bindings can include coercion bindings, but not via superclasses
216 -- See Note [Top-level evidence]
217 combineEvBinds [] val_prs
218 = [Rec val_prs]
219 combineEvBinds (NonRec b r : bs) val_prs
220 | isId b = combineEvBinds bs ((b,r):val_prs)
221 | otherwise = NonRec b r : combineEvBinds bs val_prs
222 combineEvBinds (Rec prs : bs) val_prs
223 = combineEvBinds bs (prs ++ val_prs)
224
225 {-
226 Note [Top-level evidence]
227 ~~~~~~~~~~~~~~~~~~~~~~~~~
228 Top-level evidence bindings may be mutually recursive with the top-level value
229 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
230 because the occurrence analyser doesn't teke account of type/coercion variables
231 when computing dependencies.
232
233 So we pull out the type/coercion variables (which are in dependency order),
234 and Rec the rest.
235 -}
236
237 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
238
239 deSugarExpr hsc_env tc_expr
240 = do { let dflags = hsc_dflags hsc_env
241 icntxt = hsc_IC hsc_env
242 rdr_env = ic_rn_gbl_env icntxt
243 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
244 fam_insts = snd (ic_instances icntxt)
245 fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
246 -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
247
248 ; showPass dflags "Desugar"
249
250 -- Do desugaring
251 ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
252 type_env fam_inst_env $
253 dsLExpr tc_expr
254
255 ; case mb_core_expr of
256 Nothing -> return ()
257 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
258
259 ; return (msgs, mb_core_expr) }
260
261 {-
262 ************************************************************************
263 * *
264 * Add rules and export flags to binders
265 * *
266 ************************************************************************
267 -}
268
269 addExportFlagsAndRules
270 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
271 -> [(Id, t)] -> [(Id, t)]
272 addExportFlagsAndRules target exports keep_alive rules prs
273 = mapFst add_one prs
274 where
275 add_one bndr = add_rules name (add_export name bndr)
276 where
277 name = idName bndr
278
279 ---------- Rules --------
280 -- See Note [Attach rules to local ids]
281 -- NB: the binder might have some existing rules,
282 -- arising from specialisation pragmas
283 add_rules name bndr
284 | Just rules <- lookupNameEnv rule_base name
285 = bndr `addIdSpecialisations` rules
286 | otherwise
287 = bndr
288 rule_base = extendRuleBaseList emptyRuleBase rules
289
290 ---------- Export flag --------
291 -- See Note [Adding export flags]
292 add_export name bndr
293 | dont_discard name = setIdExported bndr
294 | otherwise = bndr
295
296 dont_discard :: Name -> Bool
297 dont_discard name = is_exported name
298 || name `elemNameSet` keep_alive
299
300 -- In interactive mode, we don't want to discard any top-level
301 -- entities at all (eg. do not inline them away during
302 -- simplification), and retain them all in the TypeEnv so they are
303 -- available from the command line.
304 --
305 -- isExternalName separates the user-defined top-level names from those
306 -- introduced by the type checker.
307 is_exported :: Name -> Bool
308 is_exported | targetRetainsAllBindings target = isExternalName
309 | otherwise = (`elemNameSet` exports)
310
311 {-
312 Note [Adding export flags]
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~
314 Set the no-discard flag if either
315 a) the Id is exported
316 b) it's mentioned in the RHS of an orphan rule
317 c) it's in the keep-alive set
318
319 It means that the binding won't be discarded EVEN if the binding
320 ends up being trivial (v = w) -- the simplifier would usually just
321 substitute w for v throughout, but we don't apply the substitution to
322 the rules (maybe we should?), so this substitution would make the rule
323 bogus.
324
325 You might wonder why exported Ids aren't already marked as such;
326 it's just because the type checker is rather busy already and
327 I didn't want to pass in yet another mapping.
328
329 Note [Attach rules to local ids]
330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
331 Find the rules for locally-defined Ids; then we can attach them
332 to the binders in the top-level bindings
333
334 Reason
335 - It makes the rules easier to look up
336 - It means that transformation rules and specialisations for
337 locally defined Ids are handled uniformly
338 - It keeps alive things that are referred to only from a rule
339 (the occurrence analyser knows about rules attached to Ids)
340 - It makes sure that, when we apply a rule, the free vars
341 of the RHS are more likely to be in scope
342 - The imported rules are carried in the in-scope set
343 which is extended on each iteration by the new wave of
344 local binders; any rules which aren't on the binding will
345 thereby get dropped
346
347
348 ************************************************************************
349 * *
350 * Desugaring transformation rules
351 * *
352 ************************************************************************
353 -}
354
355 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
356 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
357 = putSrcSpanDs loc $
358 do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
359
360 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
361 unsetWOptM Opt_WarnIdentities $
362 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
363
364 ; rhs' <- dsLExpr rhs
365 ; dflags <- getDynFlags
366
367 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
368
369 -- Substitute the dict bindings eagerly,
370 -- and take the body apart into a (f args) form
371 ; case decomposeRuleLhs bndrs'' lhs'' of {
372 Left msg -> do { warnDs msg; return Nothing } ;
373 Right (final_bndrs, fn_id, args) -> do
374
375 { let is_local = isLocalId fn_id
376 -- NB: isLocalId is False of implicit Ids. This is good because
377 -- we don't want to attach rules to the bindings of implicit Ids,
378 -- because they don't show up in the bindings until just before code gen
379 fn_name = idName fn_id
380 final_rhs = simpleOptExpr rhs'' -- De-crap it
381 rule = mkRule False {- Not auto -} is_local
382 (unLoc name) act fn_name final_bndrs args
383 final_rhs
384
385 inline_shadows_rule -- Function can be inlined before rule fires
386 | wopt Opt_WarnInlineRuleShadowing dflags
387 , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
388 -- If imported with no unfolding, no worries
389 = case (idInlineActivation fn_id, act) of
390 (NeverActive, _) -> False
391 (AlwaysActive, _) -> True
392 (ActiveBefore {}, _) -> True
393 (ActiveAfter {}, NeverActive) -> True
394 (ActiveAfter n, ActiveAfter r) -> r < n -- Rule active strictly first
395 (ActiveAfter {}, AlwaysActive) -> False
396 (ActiveAfter {}, ActiveBefore {}) -> False
397 | otherwise = False
398
399 ; when inline_shadows_rule $
400 warnDs (vcat [ hang (ptext (sLit "Rule")
401 <+> doubleQuotes (ftext $ unLoc name)
402 <+> ptext (sLit "may never fire"))
403 2 (ptext (sLit "because") <+> quotes (ppr fn_id)
404 <+> ptext (sLit "might inline first"))
405 , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")
406 <+> quotes (ppr fn_id) ])
407
408 ; return (Just rule)
409 } } }
410
411 -- See Note [Desugaring coerce as cast]
412 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
413 unfold_coerce bndrs lhs rhs = do
414 (bndrs', wrap) <- go bndrs
415 return (bndrs', wrap lhs, wrap rhs)
416 where
417 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
418 go [] = return ([], id)
419 go (v:vs)
420 | Just (tc, args) <- splitTyConApp_maybe (idType v)
421 , tc == coercibleTyCon = do
422 let ty' = mkTyConApp eqReprPrimTyCon args
423 v' <- mkDerivedLocalM mkRepEqOcc v ty'
424
425 (bndrs, wrap) <- go vs
426 return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
427 | otherwise = do
428 (bndrs,wrap) <- go vs
429 return (v:bndrs, wrap)
430
431 {-
432 Note [Desugaring RULE left hand sides]
433 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
434 For the LHS of a RULE we do *not* want to desugar
435 [x] to build (\cn. x `c` n)
436 We want to leave explicit lists simply as chains
437 of cons's. We can achieve that slightly indirectly by
438 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
439
440 That keeps the desugaring of list comprehensions simple too.
441
442
443
444 Nor do we want to warn of conversion identities on the LHS;
445 the rule is precisly to optimise them:
446 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
447
448
449 Note [Desugaring coerce as cast]
450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
451 We want the user to express a rule saying roughly “mapping a coercion over a
452 list can be replaced by a coercion”. But the cast operator of Core () cannot
453 be written in Haskell. So we use `coerce` for that (#2110). The user writes
454 map coerce = coerce
455 as a RULE, and this optimizes any kind of mapped' casts aways, including `map
456 MkNewtype`.
457
458 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
459 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
460 `let c = MkCoercible co in ...`. This is later simplified to the desired form
461 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
462
463 ************************************************************************
464 * *
465 * Desugaring vectorisation declarations
466 * *
467 ************************************************************************
468 -}
469
470 dsVect :: LVectDecl Id -> DsM CoreVect
471 dsVect (L loc (HsVect (L _ v) rhs))
472 = putSrcSpanDs loc $
473 do { rhs' <- dsLExpr rhs
474 ; return $ Vect v rhs'
475 }
476 dsVect (L _loc (HsNoVect (L _ v)))
477 = return $ NoVect v
478 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
479 = return $ VectType isScalar tycon' rhs_tycon
480 where
481 tycon' | Just ty <- coreView $ mkTyConTy tycon
482 , (tycon', []) <- splitTyConApp ty = tycon'
483 | otherwise = tycon
484 dsVect vd@(L _ (HsVectTypeIn _ _ _))
485 = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
486 dsVect (L _loc (HsVectClassOut cls))
487 = return $ VectClass (classTyCon cls)
488 dsVect vc@(L _ (HsVectClassIn _))
489 = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
490 dsVect (L _loc (HsVectInstOut inst))
491 = return $ VectInst (instanceDFunId inst)
492 dsVect vi@(L _ (HsVectInstIn _))
493 = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)