Fix #481: use a safe recompilation check when Template Haskell is
[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 module Desugar ( deSugar, deSugarExpr ) where
10
11 import DynFlags
12 import StaticFlags
13 import HscTypes
14 import HsSyn
15 import TcRnTypes
16 import MkIface
17 import Id
18 import Name
19 import CoreSyn
20 import CoreSubst
21 import PprCore
22 import DsMonad
23 import DsExpr
24 import DsBinds
25 import DsForeign
26 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
27                                 -- depends on DsExpr.hi-boot.
28 import Module
29 import RdrName
30 import NameSet
31 import NameEnv
32 import Rules
33 import CoreMonad        ( endPass, CoreToDo(..) )
34 import ErrUtils
35 import Outputable
36 import SrcLoc
37 import Coverage
38 import Util
39 import MonadUtils
40 import OrdList
41 import Data.List
42 import Data.IORef
43 \end{code}
44
45 %************************************************************************
46 %*                                                                      *
47 %*              The main function: deSugar
48 %*                                                                      *
49 %************************************************************************
50
51 \begin{code}
52 -- | Main entry point to the desugarer.
53 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
54 -- Can modify PCS by faulting in more declarations
55
56 deSugar hsc_env 
57         mod_loc
58         tcg_env@(TcGblEnv { tcg_mod          = mod,
59                             tcg_src          = hsc_src,
60                             tcg_type_env     = type_env,
61                             tcg_imports      = imports,
62                             tcg_exports      = exports,
63                             tcg_keep         = keep_var,
64                             tcg_th_splice_used = tc_splice_used,
65                             tcg_rdr_env      = rdr_env,
66                             tcg_fix_env      = fix_env,
67                             tcg_inst_env     = inst_env,
68                             tcg_fam_inst_env = fam_inst_env,
69                             tcg_warns        = warns,
70                             tcg_anns         = anns,
71                             tcg_binds        = binds,
72                             tcg_imp_specs    = imp_specs,
73                             tcg_ev_binds     = ev_binds,
74                             tcg_fords        = fords,
75                             tcg_rules        = rules,
76                             tcg_vects        = vects,
77                             tcg_insts        = insts,
78                             tcg_fam_insts    = fam_insts,
79                             tcg_hpc          = other_hpc_info })
80
81   = do  { let dflags = hsc_dflags hsc_env
82         ; showPass dflags "Desugar"
83
84         -- Desugar the program
85         ; let export_set = availsToNameSet exports
86         ; let auto_scc = mkAutoScc dflags mod export_set
87         ; let target = hscTarget dflags
88         ; let hpcInfo = emptyHpcInfo other_hpc_info
89         ; (msgs, mb_res)
90               <- case target of
91                    HscNothing ->
92                        return (emptyMessages,
93                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
94                    _        -> do
95                      (binds_cvr,ds_hpc_info, modBreaks)
96                          <- if (opt_Hpc
97                                   || target == HscInterpreted)
98                                && (not (isHsBoot hsc_src))
99                               then addCoverageTicksToBinds dflags mod mod_loc
100                                                            (typeEnvTyCons type_env) binds 
101                               else return (binds, hpcInfo, emptyModBreaks)
102                      initDs hsc_env mod rdr_env type_env $ do
103                        do { ds_ev_binds <- dsEvBinds ev_binds
104                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
105                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
106                           ; (ds_fords, foreign_prs) <- dsForeigns fords
107                           ; ds_rules <- mapMaybeM dsRule rules
108                           ; ds_vects <- mapM dsVect vects
109                           ; let hpc_init
110                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
111                                   | otherwise = empty
112                           ; return ( ds_ev_binds
113                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
114                                    , spec_rules ++ ds_rules, ds_vects
115                                    , ds_fords `appendStubC` hpc_init
116                                    , ds_hpc_info, modBreaks) }
117
118         ; case mb_res of {
119            Nothing -> return (msgs, Nothing) ;
120            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
121
122         {       -- Add export flags to bindings
123           keep_alive <- readIORef keep_var
124         ; let (rules_for_locals, rules_for_imps) 
125                    = partition isLocalRule all_rules
126               final_prs = addExportFlagsAndRules target
127                               export_set keep_alive rules_for_locals (fromOL all_prs)
128
129               final_pgm = combineEvBinds ds_ev_binds final_prs
130         -- Notice that we put the whole lot in a big Rec, even the foreign binds
131         -- When compiling PrelFloat, which defines data Float = F# Float#
132         -- we want F# to be in scope in the foreign marshalling code!
133         -- You might think it doesn't matter, but the simplifier brings all top-level
134         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
135
136         -- Lint result if necessary, and print
137         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
138                (vcat [ pprCoreBindings final_pgm
139                      , pprRules rules_for_imps ])
140
141         ; (ds_binds, ds_rules_for_imps, ds_vects) 
142             <- simpleOptPgm dflags final_pgm rules_for_imps vects0
143                          -- The simpleOptPgm gets rid of type 
144                          -- bindings plus any stupid dead code
145
146         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
147
148         ; let used_names = mkUsedNames tcg_env
149         ; deps <- mkDependencies tcg_env
150
151         ; used_th <- readIORef tc_splice_used
152
153         ; let mod_guts = ModGuts {
154                 mg_module       = mod,
155                 mg_boot         = isHsBoot hsc_src,
156                 mg_exports      = exports,
157                 mg_deps         = deps,
158                 mg_used_names   = used_names,
159                 mg_used_th      = used_th,
160                 mg_dir_imps     = imp_mods imports,
161                 mg_rdr_env      = rdr_env,
162                 mg_fix_env      = fix_env,
163                 mg_warns        = warns,
164                 mg_anns         = anns,
165                 mg_types        = type_env,
166                 mg_insts        = insts,
167                 mg_fam_insts    = fam_insts,
168                 mg_inst_env     = inst_env,
169                 mg_fam_inst_env = fam_inst_env,
170                 mg_rules        = ds_rules_for_imps,
171                 mg_binds        = ds_binds,
172                 mg_foreign      = ds_fords,
173                 mg_hpc_info     = ds_hpc_info,
174                 mg_modBreaks    = modBreaks,
175                 mg_vect_decls   = ds_vects,
176                 mg_vect_info    = noVectInfo,
177                 mg_trust_pkg    = imp_trust_own_pkg imports
178               }
179         ; return (msgs, Just mod_guts)
180         }}}
181
182 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
183 dsImpSpecs imp_specs
184  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
185       ; let (spec_binds, spec_rules) = unzip spec_prs
186       ; return (concatOL spec_binds, spec_rules) }
187
188 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
189 -- Top-level bindings can include coercion bindings, but not via superclasses
190 -- See Note [Top-level evidence]
191 combineEvBinds [] val_prs 
192   = [Rec val_prs]
193 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
194   | isId b    = combineEvBinds bs ((b,r):val_prs)
195   | otherwise = NonRec b r : combineEvBinds bs val_prs
196 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs 
197   = combineEvBinds bs (prs ++ val_prs)
198 combineEvBinds (CaseEvBind x _ _ : _) _
199   = pprPanic "topEvBindPairs" (ppr x)
200 \end{code}
201
202 Note [Top-level evidence]
203 ~~~~~~~~~~~~~~~~~~~~~~~~~
204 Top-level evidence bindings may be mutually recursive with the top-level value
205 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
206 because the occurrence analyser doesn't teke account of type/coercion variables
207 when computing dependencies.  
208
209 So we pull out the type/coercion variables (which are in dependency order),
210 and Rec the rest.
211
212
213 \begin{code}
214 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
215 mkAutoScc dflags mod exports
216   | not opt_SccProfilingOn      -- No profiling
217   = NoSccs              
218     -- Add auto-scc on all top-level things
219   | dopt Opt_AutoSccsOnAllToplevs dflags
220   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
221     -- See #1641.  This is pretty yucky, but I can't see a better way
222     -- to identify compiler-generated Ids, and at least this should
223     -- catch them all.
224     -- Only on exported things
225   | dopt Opt_AutoSccsOnExportedToplevs dflags
226   = AddSccs mod (\id -> idName id `elemNameSet` exports)
227   | otherwise
228   = NoSccs
229
230 deSugarExpr :: HscEnv
231             -> Module -> GlobalRdrEnv -> TypeEnv 
232             -> LHsExpr Id
233             -> IO (Messages, Maybe CoreExpr)
234 -- Prints its own errors; returns Nothing if error occurred
235
236 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
237     let dflags = hsc_dflags hsc_env
238     showPass dflags "Desugar"
239
240     -- Do desugaring
241     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
242                                    dsLExpr tc_expr
243
244     case mb_core_expr of
245       Nothing   -> return (msgs, Nothing)
246       Just expr -> do
247
248         -- Dump output
249         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
250
251         return (msgs, Just expr)
252 \end{code}
253
254 %************************************************************************
255 %*                                                                      *
256 %*              Add rules and export flags to binders
257 %*                                                                      *
258 %************************************************************************
259
260 \begin{code}
261 addExportFlagsAndRules 
262     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
263     -> [(Id, t)] -> [(Id, t)]
264 addExportFlagsAndRules target exports keep_alive rules prs
265   = mapFst add_one prs
266   where
267     add_one bndr = add_rules name (add_export name bndr)
268        where
269          name = idName bndr
270
271     ---------- Rules --------
272         -- See Note [Attach rules to local ids]
273         -- NB: the binder might have some existing rules,
274         -- arising from specialisation pragmas
275     add_rules name bndr
276         | Just rules <- lookupNameEnv rule_base name
277         = bndr `addIdSpecialisations` rules
278         | otherwise
279         = bndr
280     rule_base = extendRuleBaseList emptyRuleBase rules
281
282     ---------- Export flag --------
283     -- See Note [Adding export flags]
284     add_export name bndr
285         | dont_discard name = setIdExported bndr
286         | otherwise         = bndr
287
288     dont_discard :: Name -> Bool
289     dont_discard name = is_exported name
290                      || name `elemNameSet` keep_alive
291
292         -- In interactive mode, we don't want to discard any top-level
293         -- entities at all (eg. do not inline them away during
294         -- simplification), and retain them all in the TypeEnv so they are
295         -- available from the command line.
296         --
297         -- isExternalName separates the user-defined top-level names from those
298         -- introduced by the type checker.
299     is_exported :: Name -> Bool
300     is_exported | target == HscInterpreted = isExternalName
301                 | otherwise                = (`elemNameSet` exports)
302 \end{code}
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 \begin{code}
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 | RuleBndr (L _ var) <- vars]
352
353         ; lhs' <- unsetDOptM Opt_EnableRewriteRules $
354                   unsetWOptM Opt_WarnIdentities $
355                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
356
357         ; rhs' <- dsLExpr rhs
358
359         -- Substitute the dict bindings eagerly,
360         -- and take the body apart into a (f args) form
361         ; case decomposeRuleLhs bndrs' lhs' of {
362                 Left msg -> do { warnDs msg; return Nothing } ;
363                 Right (final_bndrs, fn_id, args) -> do
364         
365         { let is_local = isLocalId fn_id
366                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
367                 -- we don't want to attach rules to the bindings of implicit Ids, 
368                 -- because they don't show up in the bindings until just before code gen
369               fn_name   = idName fn_id
370               final_rhs = simpleOptExpr rhs'    -- De-crap it
371               rule      = mkRule False {- Not auto -} is_local 
372                                  name act fn_name final_bndrs args final_rhs
373         ; return (Just rule)
374         } } }
375 \end{code}
376
377 Note [Desugaring RULE left hand sides]
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 For the LHS of a RULE we do *not* want to desugar
380     [x]   to    build (\cn. x `c` n)
381 We want to leave explicit lists simply as chains
382 of cons's. We can achieve that slightly indirectly by
383 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
384
385 That keeps the desugaring of list comprehensions simple too.
386
387
388
389 Nor do we want to warn of conversion identities on the LHS;
390 the rule is precisly to optimise them:
391   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
392
393
394 %************************************************************************
395 %*                                                                      *
396 %*              Desugaring vectorisation declarations
397 %*                                                                      *
398 %************************************************************************
399
400 \begin{code}
401 dsVect :: LVectDecl Id -> DsM CoreVect
402 dsVect (L loc (HsVect (L _ v) rhs))
403   = putSrcSpanDs loc $ 
404     do { rhs' <- fmapMaybeM dsLExpr rhs
405        ; return $ Vect v rhs'
406            }
407 dsVect (L _loc (HsNoVect (L _ v)))
408   = return $ NoVect v
409 \end{code}