aa9748ee3534c8ec7c6172625fb3797a708560a9
[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 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE ViewPatterns #-}
12
13 module Desugar (
14 -- * Desugaring operations
15 deSugar, deSugarExpr
16 ) where
17
18 #include "HsVersions.h"
19
20 import GhcPrelude
21
22 import DsUsage
23 import DynFlags
24 import HscTypes
25 import HsSyn
26 import TcRnTypes
27 import TcRnMonad ( finalSafeMode, fixSafeInstances )
28 import TcRnDriver ( runTcInteractive )
29 import Id
30 import Name
31 import Type
32 import Avail
33 import CoreSyn
34 import CoreFVs ( exprsSomeFreeVarsList )
35 import CoreOpt ( simpleOptPgm, simpleOptExpr )
36 import PprCore
37 import DsMonad
38 import DsExpr
39 import DsBinds
40 import DsForeign
41 import PrelNames ( coercibleTyConKey )
42 import TysPrim ( eqReprPrimTyCon )
43 import Unique ( hasKey )
44 import Coercion ( mkCoVarCo )
45 import TysWiredIn ( coercibleDataCon )
46 import DataCon ( dataConWrapId )
47 import MkCore ( mkCoreLet )
48 import Module
49 import NameSet
50 import NameEnv
51 import Rules
52 import BasicTypes ( Activation(.. ), competesWith, pprRuleName )
53 import CoreMonad ( CoreToDo(..) )
54 import CoreLint ( endPassIO )
55 import VarSet
56 import FastString
57 import ErrUtils
58 import Outputable
59 import SrcLoc
60 import Coverage
61 import Util
62 import MonadUtils
63 import OrdList
64 import ExtractDocs
65
66 import Data.List
67 import Data.IORef
68 import Control.Monad( when )
69 import Plugins ( LoadedPlugin(..) )
70
71 {-
72 ************************************************************************
73 * *
74 * The main function: deSugar
75 * *
76 ************************************************************************
77 -}
78
79 -- | Main entry point to the desugarer.
80 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
81 -- Can modify PCS by faulting in more declarations
82
83 deSugar hsc_env
84 mod_loc
85 tcg_env@(TcGblEnv { tcg_mod = id_mod,
86 tcg_semantic_mod = mod,
87 tcg_src = hsc_src,
88 tcg_type_env = type_env,
89 tcg_imports = imports,
90 tcg_exports = exports,
91 tcg_keep = keep_var,
92 tcg_th_splice_used = tc_splice_used,
93 tcg_rdr_env = rdr_env,
94 tcg_fix_env = fix_env,
95 tcg_inst_env = inst_env,
96 tcg_fam_inst_env = fam_inst_env,
97 tcg_merged = merged,
98 tcg_warns = warns,
99 tcg_anns = anns,
100 tcg_binds = binds,
101 tcg_imp_specs = imp_specs,
102 tcg_dependent_files = dependent_files,
103 tcg_ev_binds = ev_binds,
104 tcg_th_foreign_files = th_foreign_files_var,
105 tcg_fords = fords,
106 tcg_rules = rules,
107 tcg_patsyns = patsyns,
108 tcg_tcs = tcs,
109 tcg_insts = insts,
110 tcg_fam_insts = fam_insts,
111 tcg_hpc = other_hpc_info,
112 tcg_complete_matches = complete_matches
113 })
114
115 = do { let dflags = hsc_dflags hsc_env
116 print_unqual = mkPrintUnqualified dflags rdr_env
117 ; withTiming (pure dflags)
118 (text "Desugar"<+>brackets (ppr mod))
119 (const ()) $
120 do { -- Desugar the program
121 ; let export_set = availsToNameSet exports
122 target = hscTarget dflags
123 hpcInfo = emptyHpcInfo other_hpc_info
124
125 ; (binds_cvr, ds_hpc_info, modBreaks)
126 <- if not (isHsBootOrSig hsc_src)
127 then addTicksToBinds hsc_env mod mod_loc
128 export_set (typeEnvTyCons type_env) binds
129 else return (binds, hpcInfo, Nothing)
130 ; (msgs, mb_res) <- initDs hsc_env tcg_env $
131 do { ds_ev_binds <- dsEvBinds ev_binds
132 ; core_prs <- dsTopLHsBinds binds_cvr
133 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
134 ; (ds_fords, foreign_prs) <- dsForeigns fords
135 ; ds_rules <- mapMaybeM dsRule rules
136 ; let hpc_init
137 | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
138 | otherwise = empty
139 ; return ( ds_ev_binds
140 , foreign_prs `appOL` core_prs `appOL` spec_prs
141 , spec_rules ++ ds_rules
142 , ds_fords `appendStubC` hpc_init) }
143
144 ; case mb_res of {
145 Nothing -> return (msgs, Nothing) ;
146 Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
147
148 do { -- Add export flags to bindings
149 keep_alive <- readIORef keep_var
150 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
151 final_prs = addExportFlagsAndRules target export_set keep_alive
152 rules_for_locals (fromOL all_prs)
153
154 final_pgm = combineEvBinds ds_ev_binds final_prs
155 -- Notice that we put the whole lot in a big Rec, even the foreign binds
156 -- When compiling PrelFloat, which defines data Float = F# Float#
157 -- we want F# to be in scope in the foreign marshalling code!
158 -- You might think it doesn't matter, but the simplifier brings all top-level
159 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
160
161 ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
162 ; (ds_binds, ds_rules_for_imps)
163 <- simpleOptPgm dflags mod final_pgm rules_for_imps
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 pluginModules =
171 map lpModule (cachedPlugins (hsc_dflags hsc_env))
172 ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
173 (map mi_module pluginModules) tcg_env
174
175 ; used_th <- readIORef tc_splice_used
176 ; dep_files <- readIORef dependent_files
177 ; safe_mode <- finalSafeMode dflags tcg_env
178 ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
179 dep_files merged pluginModules
180 -- id_mod /= mod when we are processing an hsig, but hsigs
181 -- never desugared and compiled (there's no code!)
182 -- Consequently, this should hold for any ModGuts that make
183 -- past desugaring. See Note [Identity versus semantic module].
184 ; MASSERT( id_mod == mod )
185
186 ; foreign_files <- readIORef th_foreign_files_var
187
188 ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
189
190 ; let mod_guts = ModGuts {
191 mg_module = mod,
192 mg_hsc_src = hsc_src,
193 mg_loc = mkFileSrcSpan mod_loc,
194 mg_exports = exports,
195 mg_usages = usages,
196 mg_deps = deps,
197 mg_used_th = used_th,
198 mg_rdr_env = rdr_env,
199 mg_fix_env = fix_env,
200 mg_warns = warns,
201 mg_anns = anns,
202 mg_tcs = tcs,
203 mg_insts = fixSafeInstances safe_mode insts,
204 mg_fam_insts = fam_insts,
205 mg_inst_env = inst_env,
206 mg_fam_inst_env = fam_inst_env,
207 mg_patsyns = patsyns,
208 mg_rules = ds_rules_for_imps,
209 mg_binds = ds_binds,
210 mg_foreign = ds_fords,
211 mg_foreign_files = foreign_files,
212 mg_hpc_info = ds_hpc_info,
213 mg_modBreaks = modBreaks,
214 mg_safe_haskell = safe_mode,
215 mg_trust_pkg = imp_trust_own_pkg imports,
216 mg_complete_sigs = complete_matches,
217 mg_doc_hdr = doc_hdr,
218 mg_decl_docs = decl_docs,
219 mg_arg_docs = arg_docs
220 }
221 ; return (msgs, Just mod_guts)
222 }}}}
223
224 mkFileSrcSpan :: ModLocation -> SrcSpan
225 mkFileSrcSpan mod_loc
226 = case ml_hs_file mod_loc of
227 Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
228 Nothing -> interactiveSrcSpan -- Presumably
229
230 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
231 dsImpSpecs imp_specs
232 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
233 ; let (spec_binds, spec_rules) = unzip spec_prs
234 ; return (concatOL spec_binds, spec_rules) }
235
236 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
237 -- Top-level bindings can include coercion bindings, but not via superclasses
238 -- See Note [Top-level evidence]
239 combineEvBinds [] val_prs
240 = [Rec val_prs]
241 combineEvBinds (NonRec b r : bs) val_prs
242 | isId b = combineEvBinds bs ((b,r):val_prs)
243 | otherwise = NonRec b r : combineEvBinds bs val_prs
244 combineEvBinds (Rec prs : bs) val_prs
245 = combineEvBinds bs (prs ++ val_prs)
246
247 {-
248 Note [Top-level evidence]
249 ~~~~~~~~~~~~~~~~~~~~~~~~~
250 Top-level evidence bindings may be mutually recursive with the top-level value
251 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
252 because the occurrence analyser doesn't take account of type/coercion variables
253 when computing dependencies.
254
255 So we pull out the type/coercion variables (which are in dependency order),
256 and Rec the rest.
257 -}
258
259 deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
260
261 deSugarExpr hsc_env tc_expr = do {
262 let dflags = hsc_dflags hsc_env
263
264 ; showPass dflags "Desugar"
265
266 -- Do desugaring
267 ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
268 dsLExpr tc_expr
269
270 ; case mb_core_expr of
271 Nothing -> return ()
272 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
273 (pprCoreExpr expr)
274
275 ; return (msgs, mb_core_expr) }
276
277 {-
278 ************************************************************************
279 * *
280 * Add rules and export flags to binders
281 * *
282 ************************************************************************
283 -}
284
285 addExportFlagsAndRules
286 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
287 -> [(Id, t)] -> [(Id, t)]
288 addExportFlagsAndRules target exports keep_alive rules prs
289 = mapFst add_one prs
290 where
291 add_one bndr = add_rules name (add_export name bndr)
292 where
293 name = idName bndr
294
295 ---------- Rules --------
296 -- See Note [Attach rules to local ids]
297 -- NB: the binder might have some existing rules,
298 -- arising from specialisation pragmas
299 add_rules name bndr
300 | Just rules <- lookupNameEnv rule_base name
301 = bndr `addIdSpecialisations` rules
302 | otherwise
303 = bndr
304 rule_base = extendRuleBaseList emptyRuleBase rules
305
306 ---------- Export flag --------
307 -- See Note [Adding export flags]
308 add_export name bndr
309 | dont_discard name = setIdExported bndr
310 | otherwise = bndr
311
312 dont_discard :: Name -> Bool
313 dont_discard name = is_exported name
314 || name `elemNameSet` keep_alive
315
316 -- In interactive mode, we don't want to discard any top-level
317 -- entities at all (eg. do not inline them away during
318 -- simplification), and retain them all in the TypeEnv so they are
319 -- available from the command line.
320 --
321 -- isExternalName separates the user-defined top-level names from those
322 -- introduced by the type checker.
323 is_exported :: Name -> Bool
324 is_exported | targetRetainsAllBindings target = isExternalName
325 | otherwise = (`elemNameSet` exports)
326
327 {-
328 Note [Adding export flags]
329 ~~~~~~~~~~~~~~~~~~~~~~~~~~
330 Set the no-discard flag if either
331 a) the Id is exported
332 b) it's mentioned in the RHS of an orphan rule
333 c) it's in the keep-alive set
334
335 It means that the binding won't be discarded EVEN if the binding
336 ends up being trivial (v = w) -- the simplifier would usually just
337 substitute w for v throughout, but we don't apply the substitution to
338 the rules (maybe we should?), so this substitution would make the rule
339 bogus.
340
341 You might wonder why exported Ids aren't already marked as such;
342 it's just because the type checker is rather busy already and
343 I didn't want to pass in yet another mapping.
344
345 Note [Attach rules to local ids]
346 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
347 Find the rules for locally-defined Ids; then we can attach them
348 to the binders in the top-level bindings
349
350 Reason
351 - It makes the rules easier to look up
352 - It means that transformation rules and specialisations for
353 locally defined Ids are handled uniformly
354 - It keeps alive things that are referred to only from a rule
355 (the occurrence analyser knows about rules attached to Ids)
356 - It makes sure that, when we apply a rule, the free vars
357 of the RHS are more likely to be in scope
358 - The imported rules are carried in the in-scope set
359 which is extended on each iteration by the new wave of
360 local binders; any rules which aren't on the binding will
361 thereby get dropped
362
363
364 ************************************************************************
365 * *
366 * Desugaring transformation rules
367 * *
368 ************************************************************************
369 -}
370
371 dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
372 dsRule (dL->L loc (HsRule { rd_name = name
373 , rd_act = rule_act
374 , rd_tmvs = vars
375 , rd_lhs = lhs
376 , rd_rhs = rhs }))
377 = putSrcSpanDs loc $
378 do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
379
380 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
381 unsetWOptM Opt_WarnIdentities $
382 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
383
384 ; rhs' <- dsLExpr rhs
385 ; this_mod <- getModule
386
387 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
388
389 -- Substitute the dict bindings eagerly,
390 -- and take the body apart into a (f args) form
391 ; dflags <- getDynFlags
392 ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
393 Left msg -> do { warnDs NoReason msg; return Nothing } ;
394 Right (final_bndrs, fn_id, args) -> do
395
396 { let is_local = isLocalId fn_id
397 -- NB: isLocalId is False of implicit Ids. This is good because
398 -- we don't want to attach rules to the bindings of implicit Ids,
399 -- because they don't show up in the bindings until just before code gen
400 fn_name = idName fn_id
401 final_rhs = simpleOptExpr dflags rhs'' -- De-crap it
402 rule_name = snd (unLoc name)
403 final_bndrs_set = mkVarSet final_bndrs
404 arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
405 exprsSomeFreeVarsList isId args
406
407 ; rule <- dsMkUserRule this_mod is_local
408 rule_name rule_act fn_name final_bndrs args
409 final_rhs
410 ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
411 warnRuleShadowing rule_name rule_act fn_id arg_ids
412
413 ; return (Just rule)
414 } } }
415 dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
416 dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
417
418 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
419 -- See Note [Rules and inlining/other rules]
420 warnRuleShadowing rule_name rule_act fn_id arg_ids
421 = do { check False fn_id -- We often have multiple rules for the same Id in a
422 -- module. Maybe we should check that they don't overlap
423 -- but currently we don't
424 ; mapM_ (check True) arg_ids }
425 where
426 check check_rules_too lhs_id
427 | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
428 -- If imported with no unfolding, no worries
429 , idInlineActivation lhs_id `competesWith` rule_act
430 = warnDs (Reason Opt_WarnInlineRuleShadowing)
431 (vcat [ hang (text "Rule" <+> pprRuleName rule_name
432 <+> text "may never fire")
433 2 (text "because" <+> quotes (ppr lhs_id)
434 <+> text "might inline first")
435 , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
436 <+> quotes (ppr lhs_id)
437 , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
438
439 | check_rules_too
440 , bad_rule : _ <- get_bad_rules lhs_id
441 = warnDs (Reason Opt_WarnInlineRuleShadowing)
442 (vcat [ hang (text "Rule" <+> pprRuleName rule_name
443 <+> text "may never fire")
444 2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
445 <+> text "for"<+> quotes (ppr lhs_id)
446 <+> text "might fire first")
447 , text "Probable fix: add phase [n] or [~n] to the competing rule"
448 , whenPprDebug (ppr bad_rule) ])
449
450 | otherwise
451 = return ()
452
453 get_bad_rules lhs_id
454 = [ rule | rule <- idCoreRules lhs_id
455 , ruleActivation rule `competesWith` rule_act ]
456
457 -- See Note [Desugaring coerce as cast]
458 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
459 unfold_coerce bndrs lhs rhs = do
460 (bndrs', wrap) <- go bndrs
461 return (bndrs', wrap lhs, wrap rhs)
462 where
463 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
464 go [] = return ([], id)
465 go (v:vs)
466 | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
467 , tc `hasKey` coercibleTyConKey = do
468 u <- newUnique
469
470 let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
471 v' = mkLocalCoVar
472 (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
473 box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
474 [k, t1, t2] `App`
475 Coercion (mkCoVarCo v')
476
477 (bndrs, wrap) <- go vs
478 return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
479 | otherwise = do
480 (bndrs,wrap) <- go vs
481 return (v:bndrs, wrap)
482
483 {- Note [Desugaring RULE left hand sides]
484 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
485 For the LHS of a RULE we do *not* want to desugar
486 [x] to build (\cn. x `c` n)
487 We want to leave explicit lists simply as chains
488 of cons's. We can achieve that slightly indirectly by
489 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
490
491 That keeps the desugaring of list comprehensions simple too.
492
493 Nor do we want to warn of conversion identities on the LHS;
494 the rule is precisely to optimise them:
495 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
496
497 Note [Desugaring coerce as cast]
498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
499 We want the user to express a rule saying roughly “mapping a coercion over a
500 list can be replaced by a coercion”. But the cast operator of Core () cannot
501 be written in Haskell. So we use `coerce` for that (#2110). The user writes
502 map coerce = coerce
503 as a RULE, and this optimizes any kind of mapped' casts away, including `map
504 MkNewtype`.
505
506 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
507 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
508 `let c = MkCoercible co in ...`. This is later simplified to the desired form
509 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
510 See also Note [Getting the map/coerce RULE to work] in CoreSubst.
511
512 Note [Rules and inlining/other rules]
513 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
514 If you have
515 f x = ...
516 g x = ...
517 {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
518 then there's a good chance that in a potential rule redex
519 ...f (g e)...
520 then 'f' or 'g' will inline befor the rule can fire. Solution: add an
521 INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
522
523 Note that this applies to all the free variables on the LHS, both the
524 main function and things in its arguments.
525
526 We also check if there are Ids on the LHS that have competing RULES.
527 In the above example, suppose we had
528 {-# RULES "rule-for-g" forally. g [y] = ... #-}
529 Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
530 control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
531 active; or perhpas after "rule-for-g" has become inactive. This is checked
532 by 'competesWith'
533
534 Class methods have a built-in RULE to select the method from the dictionary,
535 so you can't change the phase on this. That makes id very dubious to
536 match on class methods in RULE lhs's. See Trac #10595. I'm not happy
537 about this. For example in Control.Arrow we have
538
539 {-# RULES "compose/arr" forall f g .
540 (arr f) . (arr g) = arr (f . g) #-}
541
542 and similar, which will elicit exactly these warnings, and risk never
543 firing. But it's not clear what to do instead. We could make the
544 class method rules inactive in phase 2, but that would delay when
545 subsequent transformations could fire.
546 -}