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