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