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