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