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