Unify hsig and hs-boot; add preliminary "hs-boot" merging.
[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 (isHsBoot 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_loc = mkFileSrcSpan mod_loc,
175 mg_exports = exports,
176 mg_deps = deps,
177 mg_used_names = used_names,
178 mg_used_th = used_th,
179 mg_dir_imps = imp_mods imports,
180 mg_rdr_env = rdr_env,
181 mg_fix_env = fix_env,
182 mg_warns = warns,
183 mg_anns = anns,
184 mg_tcs = tcs,
185 mg_insts = fixSafeInstances safe_mode insts,
186 mg_fam_insts = fam_insts,
187 mg_inst_env = inst_env,
188 mg_fam_inst_env = fam_inst_env,
189 mg_patsyns = patsyns,
190 mg_rules = ds_rules_for_imps,
191 mg_binds = ds_binds,
192 mg_foreign = ds_fords,
193 mg_hpc_info = ds_hpc_info,
194 mg_modBreaks = modBreaks,
195 mg_vect_decls = ds_vects,
196 mg_vect_info = noVectInfo,
197 mg_safe_haskell = safe_mode,
198 mg_trust_pkg = imp_trust_own_pkg imports,
199 mg_dependent_files = dep_files
200 }
201 ; return (msgs, Just mod_guts)
202 }}}
203
204 mkFileSrcSpan :: ModLocation -> SrcSpan
205 mkFileSrcSpan mod_loc
206 = case ml_hs_file mod_loc of
207 Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
208 Nothing -> interactiveSrcSpan -- Presumably
209
210 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
211 dsImpSpecs imp_specs
212 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
213 ; let (spec_binds, spec_rules) = unzip spec_prs
214 ; return (concatOL spec_binds, spec_rules) }
215
216 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
217 -- Top-level bindings can include coercion bindings, but not via superclasses
218 -- See Note [Top-level evidence]
219 combineEvBinds [] val_prs
220 = [Rec val_prs]
221 combineEvBinds (NonRec b r : bs) val_prs
222 | isId b = combineEvBinds bs ((b,r):val_prs)
223 | otherwise = NonRec b r : combineEvBinds bs val_prs
224 combineEvBinds (Rec prs : bs) val_prs
225 = combineEvBinds bs (prs ++ val_prs)
226
227 {-
228 Note [Top-level evidence]
229 ~~~~~~~~~~~~~~~~~~~~~~~~~
230 Top-level evidence bindings may be mutually recursive with the top-level value
231 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
232 because the occurrence analyser doesn't teke account of type/coercion variables
233 when computing dependencies.
234
235 So we pull out the type/coercion variables (which are in dependency order),
236 and Rec the rest.
237 -}
238
239 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
240
241 deSugarExpr hsc_env tc_expr
242 = do { let dflags = hsc_dflags hsc_env
243 icntxt = hsc_IC hsc_env
244 rdr_env = ic_rn_gbl_env icntxt
245 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
246 fam_insts = snd (ic_instances icntxt)
247 fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
248 -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
249
250 ; showPass dflags "Desugar"
251
252 -- Do desugaring
253 ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
254 type_env fam_inst_env $
255 dsLExpr tc_expr
256
257 ; case mb_core_expr of
258 Nothing -> return ()
259 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
260
261 ; return (msgs, mb_core_expr) }
262
263 {-
264 ************************************************************************
265 * *
266 * Add rules and export flags to binders
267 * *
268 ************************************************************************
269 -}
270
271 addExportFlagsAndRules
272 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
273 -> [(Id, t)] -> [(Id, t)]
274 addExportFlagsAndRules target exports keep_alive rules prs
275 = mapFst add_one prs
276 where
277 add_one bndr = add_rules name (add_export name bndr)
278 where
279 name = idName bndr
280
281 ---------- Rules --------
282 -- See Note [Attach rules to local ids]
283 -- NB: the binder might have some existing rules,
284 -- arising from specialisation pragmas
285 add_rules name bndr
286 | Just rules <- lookupNameEnv rule_base name
287 = bndr `addIdSpecialisations` rules
288 | otherwise
289 = bndr
290 rule_base = extendRuleBaseList emptyRuleBase rules
291
292 ---------- Export flag --------
293 -- See Note [Adding export flags]
294 add_export name bndr
295 | dont_discard name = setIdExported bndr
296 | otherwise = bndr
297
298 dont_discard :: Name -> Bool
299 dont_discard name = is_exported name
300 || name `elemNameSet` keep_alive
301
302 -- In interactive mode, we don't want to discard any top-level
303 -- entities at all (eg. do not inline them away during
304 -- simplification), and retain them all in the TypeEnv so they are
305 -- available from the command line.
306 --
307 -- isExternalName separates the user-defined top-level names from those
308 -- introduced by the type checker.
309 is_exported :: Name -> Bool
310 is_exported | targetRetainsAllBindings target = isExternalName
311 | otherwise = (`elemNameSet` exports)
312
313 {-
314 Note [Adding export flags]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~
316 Set the no-discard flag if either
317 a) the Id is exported
318 b) it's mentioned in the RHS of an orphan rule
319 c) it's in the keep-alive set
320
321 It means that the binding won't be discarded EVEN if the binding
322 ends up being trivial (v = w) -- the simplifier would usually just
323 substitute w for v throughout, but we don't apply the substitution to
324 the rules (maybe we should?), so this substitution would make the rule
325 bogus.
326
327 You might wonder why exported Ids aren't already marked as such;
328 it's just because the type checker is rather busy already and
329 I didn't want to pass in yet another mapping.
330
331 Note [Attach rules to local ids]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 Find the rules for locally-defined Ids; then we can attach them
334 to the binders in the top-level bindings
335
336 Reason
337 - It makes the rules easier to look up
338 - It means that transformation rules and specialisations for
339 locally defined Ids are handled uniformly
340 - It keeps alive things that are referred to only from a rule
341 (the occurrence analyser knows about rules attached to Ids)
342 - It makes sure that, when we apply a rule, the free vars
343 of the RHS are more likely to be in scope
344 - The imported rules are carried in the in-scope set
345 which is extended on each iteration by the new wave of
346 local binders; any rules which aren't on the binding will
347 thereby get dropped
348
349
350 ************************************************************************
351 * *
352 * Desugaring transformation rules
353 * *
354 ************************************************************************
355 -}
356
357 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
358 dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
359 = putSrcSpanDs loc $
360 do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
361
362 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
363 unsetWOptM Opt_WarnIdentities $
364 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
365
366 ; rhs' <- dsLExpr rhs
367 ; this_mod <- getModule
368
369 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
370
371 -- Substitute the dict bindings eagerly,
372 -- and take the body apart into a (f args) form
373 ; case decomposeRuleLhs bndrs'' lhs'' of {
374 Left msg -> do { warnDs msg; return Nothing } ;
375 Right (final_bndrs, fn_id, args) -> do
376
377 { let is_local = isLocalId fn_id
378 -- NB: isLocalId is False of implicit Ids. This is good because
379 -- we don't want to attach rules to the bindings of implicit Ids,
380 -- because they don't show up in the bindings until just before code gen
381 fn_name = idName fn_id
382 final_rhs = simpleOptExpr rhs'' -- De-crap it
383 rule_name = snd (unLoc name)
384 rule = mkRule this_mod False {- Not auto -} is_local
385 rule_name rule_act fn_name final_bndrs args
386 final_rhs
387 arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
388
389 ; dflags <- getDynFlags
390 ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
391 warnRuleShadowing rule_name rule_act fn_id arg_ids
392
393 ; return (Just rule)
394 } } }
395
396
397 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
398 -- See Note [Rules and inlining/other rules]
399 warnRuleShadowing rule_name rule_act fn_id arg_ids
400 = do { check False fn_id -- We often have multiple rules for the same Id in a
401 -- module. Maybe we should check that they don't overlap
402 -- but currently we don't
403 ; mapM_ (check True) arg_ids }
404 where
405 check check_rules_too lhs_id
406 | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
407 -- If imported with no unfolding, no worries
408 , idInlineActivation lhs_id `competesWith` rule_act
409 = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
410 <+> ptext (sLit "may never fire"))
411 2 (ptext (sLit "because") <+> quotes (ppr lhs_id)
412 <+> ptext (sLit "might inline first"))
413 , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for")
414 <+> quotes (ppr lhs_id)
415 , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
416
417 | check_rules_too
418 , bad_rule : _ <- get_bad_rules lhs_id
419 = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
420 <+> ptext (sLit "may never fire"))
421 2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule)
422 <+> ptext (sLit "for")<+> quotes (ppr lhs_id)
423 <+> ptext (sLit "might fire first"))
424 , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule")
425 , ifPprDebug (ppr bad_rule) ])
426
427 | otherwise
428 = return ()
429
430 get_bad_rules lhs_id
431 = [ rule | rule <- idCoreRules lhs_id
432 , ruleActivation rule `competesWith` rule_act ]
433
434 -- See Note [Desugaring coerce as cast]
435 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
436 unfold_coerce bndrs lhs rhs = do
437 (bndrs', wrap) <- go bndrs
438 return (bndrs', wrap lhs, wrap rhs)
439 where
440 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
441 go [] = return ([], id)
442 go (v:vs)
443 | Just (tc, args) <- splitTyConApp_maybe (idType v)
444 , tc == coercibleTyCon = do
445 let ty' = mkTyConApp eqReprPrimTyCon args
446 v' <- mkDerivedLocalM mkRepEqOcc v ty'
447
448 (bndrs, wrap) <- go vs
449 return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
450 | otherwise = do
451 (bndrs,wrap) <- go vs
452 return (v:bndrs, wrap)
453
454 {- Note [Desugaring RULE left hand sides]
455 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
456 For the LHS of a RULE we do *not* want to desugar
457 [x] to build (\cn. x `c` n)
458 We want to leave explicit lists simply as chains
459 of cons's. We can achieve that slightly indirectly by
460 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
461
462 That keeps the desugaring of list comprehensions simple too.
463
464
465
466 Nor do we want to warn of conversion identities on the LHS;
467 the rule is precisly to optimise them:
468 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
469
470 Note [Desugaring coerce as cast]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 We want the user to express a rule saying roughly “mapping a coercion over a
473 list can be replaced by a coercion”. But the cast operator of Core () cannot
474 be written in Haskell. So we use `coerce` for that (#2110). The user writes
475 map coerce = coerce
476 as a RULE, and this optimizes any kind of mapped' casts aways, including `map
477 MkNewtype`.
478
479 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
480 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
481 `let c = MkCoercible co in ...`. This is later simplified to the desired form
482 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
483
484 Note [Rules and inlining/other rules]
485 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
486 If you have
487 f x = ...
488 g x = ...
489 {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
490 then there's a good chance that in a potential rule redex
491 ...f (g e)...
492 then 'f' or 'g' will inline befor the rule can fire. Solution: add an
493 INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
494
495 Note that this applies to all the free variables on the LHS, both the
496 main function and things in its arguments.
497
498 We also check if there are Ids on the LHS that have competing RULES.
499 In the above example, suppose we had
500 {-# RULES "rule-for-g" forally. g [y] = ... #-}
501 Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
502 control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
503 active; or perhpas after "rule-for-g" has become inactive. This is checked
504 by 'competesWith'
505
506 Class methods have a built-in RULE to select the method from the dictionary,
507 so you can't change the phase on this. That makes id very dubious to
508 match on class methods in RULE lhs's. See Trac #10595. I'm not happy
509 about this. For exmaple in Control.Arrow we have
510
511 {-# RULES "compose/arr" forall f g .
512 (arr f) . (arr g) = arr (f . g) #-}
513
514 and similar, which will elicit exactly these warnings, and risk never
515 firing. But it's not clear what to do instead. We could make the
516 class methocd rules inactive in phase 2, but that would delay when
517 subsequent transformations could fire.
518
519
520 ************************************************************************
521 * *
522 * Desugaring vectorisation declarations
523 * *
524 ************************************************************************
525 -}
526
527 dsVect :: LVectDecl Id -> DsM CoreVect
528 dsVect (L loc (HsVect _ (L _ v) rhs))
529 = putSrcSpanDs loc $
530 do { rhs' <- dsLExpr rhs
531 ; return $ Vect v rhs'
532 }
533 dsVect (L _loc (HsNoVect _ (L _ v)))
534 = return $ NoVect v
535 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
536 = return $ VectType isScalar tycon' rhs_tycon
537 where
538 tycon' | Just ty <- coreView $ mkTyConTy tycon
539 , (tycon', []) <- splitTyConApp ty = tycon'
540 | otherwise = tycon
541 dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
542 = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
543 dsVect (L _loc (HsVectClassOut cls))
544 = return $ VectClass (classTyCon cls)
545 dsVect vc@(L _ (HsVectClassIn _ _))
546 = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
547 dsVect (L _loc (HsVectInstOut inst))
548 = return $ VectInst (instanceDFunId inst)
549 dsVect vi@(L _ (HsVectInstIn _))
550 = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)