5d045a80a92e13235843fd4f5bc98327d4675079
[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_rdr_env      = rdr_env,
65                             tcg_fix_env      = fix_env,
66                             tcg_inst_env     = inst_env,
67                             tcg_fam_inst_env = fam_inst_env,
68                             tcg_warns        = warns,
69                             tcg_anns         = anns,
70                             tcg_binds        = binds,
71                             tcg_imp_specs    = imp_specs,
72                             tcg_ev_binds     = ev_binds,
73                             tcg_fords        = fords,
74                             tcg_rules        = rules,
75                             tcg_vects        = vects,
76                             tcg_insts        = insts,
77                             tcg_fam_insts    = fam_insts,
78                             tcg_hpc          = other_hpc_info })
79
80   = do  { let dflags = hsc_dflags hsc_env
81         ; showPass dflags "Desugar"
82
83         -- Desugar the program
84         ; let export_set = availsToNameSet exports
85         ; let auto_scc = mkAutoScc dflags mod export_set
86         ; let target = hscTarget dflags
87         ; let hpcInfo = emptyHpcInfo other_hpc_info
88         ; (msgs, mb_res)
89               <- case target of
90                    HscNothing ->
91                        return (emptyMessages,
92                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
93                    _        -> do
94                      (binds_cvr,ds_hpc_info, modBreaks)
95                          <- if (opt_Hpc
96                                   || target == HscInterpreted)
97                                && (not (isHsBoot hsc_src))
98                               then addCoverageTicksToBinds dflags mod mod_loc
99                                                            (typeEnvTyCons type_env) binds 
100                               else return (binds, hpcInfo, emptyModBreaks)
101                      initDs hsc_env mod rdr_env type_env $ do
102                        do { ds_ev_binds <- dsEvBinds ev_binds
103                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
104                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
105                           ; (ds_fords, foreign_prs) <- dsForeigns fords
106                           ; ds_rules <- mapMaybeM dsRule rules
107                           ; ds_vects <- mapM dsVect vects
108                           ; let hpc_init
109                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
110                                   | otherwise = empty
111                           ; return ( ds_ev_binds
112                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
113                                    , spec_rules ++ ds_rules, ds_vects
114                                    , ds_fords `appendStubC` hpc_init
115                                    , ds_hpc_info, modBreaks) }
116
117         ; case mb_res of {
118            Nothing -> return (msgs, Nothing) ;
119            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
120
121         {       -- Add export flags to bindings
122           keep_alive <- readIORef keep_var
123         ; let (rules_for_locals, rules_for_imps) 
124                    = partition isLocalRule all_rules
125               final_prs = addExportFlagsAndRules target
126                               export_set keep_alive rules_for_locals (fromOL all_prs)
127
128               final_pgm = combineEvBinds ds_ev_binds final_prs
129         -- Notice that we put the whole lot in a big Rec, even the foreign binds
130         -- When compiling PrelFloat, which defines data Float = F# Float#
131         -- we want F# to be in scope in the foreign marshalling code!
132         -- You might think it doesn't matter, but the simplifier brings all top-level
133         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
134
135         -- Lint result if necessary, and print
136         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
137                (vcat [ pprCoreBindings final_pgm
138                      , pprRules rules_for_imps ])
139
140         ; (ds_binds, ds_rules_for_imps, ds_vects) 
141             <- simpleOptPgm dflags final_pgm rules_for_imps vects0
142                          -- The simpleOptPgm gets rid of type 
143                          -- bindings plus any stupid dead code
144
145         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
146
147         ; let used_names = mkUsedNames tcg_env
148         ; deps <- mkDependencies tcg_env
149
150         ; let mod_guts = ModGuts {      
151                 mg_module       = mod,
152                 mg_boot         = isHsBoot hsc_src,
153                 mg_exports      = exports,
154                 mg_deps         = deps,
155                 mg_used_names   = used_names,
156                 mg_dir_imps     = imp_mods imports,
157                 mg_rdr_env      = rdr_env,
158                 mg_fix_env      = fix_env,
159                 mg_warns        = warns,
160                 mg_anns         = anns,
161                 mg_types        = type_env,
162                 mg_insts        = insts,
163                 mg_fam_insts    = fam_insts,
164                 mg_inst_env     = inst_env,
165                 mg_fam_inst_env = fam_inst_env,
166                 mg_rules        = ds_rules_for_imps,
167                 mg_binds        = ds_binds,
168                 mg_foreign      = ds_fords,
169                 mg_hpc_info     = ds_hpc_info,
170                 mg_modBreaks    = modBreaks,
171                 mg_vect_decls   = ds_vects,
172                 mg_vect_info    = noVectInfo,
173                 mg_trust_pkg    = imp_trust_own_pkg imports
174               }
175         ; return (msgs, Just mod_guts)
176         }}}
177
178 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
179 dsImpSpecs imp_specs
180  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
181       ; let (spec_binds, spec_rules) = unzip spec_prs
182       ; return (concatOL spec_binds, spec_rules) }
183
184 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
185 -- Top-level bindings can include coercion bindings, but not via superclasses
186 -- See Note [Top-level evidence]
187 combineEvBinds [] val_prs 
188   = [Rec val_prs]
189 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
190   | isId b    = combineEvBinds bs ((b,r):val_prs)
191   | otherwise = NonRec b r : combineEvBinds bs val_prs
192 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs 
193   = combineEvBinds bs (prs ++ val_prs)
194 combineEvBinds (CaseEvBind x _ _ : _) _
195   = pprPanic "topEvBindPairs" (ppr x)
196 \end{code}
197
198 Note [Top-level evidence]
199 ~~~~~~~~~~~~~~~~~~~~~~~~~
200 Top-level evidence bindings may be mutually recursive with the top-level value
201 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
202 because the occurrence analyser doesn't teke account of type/coercion variables
203 when computing dependencies.  
204
205 So we pull out the type/coercion variables (which are in dependency order),
206 and Rec the rest.
207
208
209 \begin{code}
210 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
211 mkAutoScc dflags mod exports
212   | not opt_SccProfilingOn      -- No profiling
213   = NoSccs              
214     -- Add auto-scc on all top-level things
215   | dopt Opt_AutoSccsOnAllToplevs dflags
216   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
217     -- See #1641.  This is pretty yucky, but I can't see a better way
218     -- to identify compiler-generated Ids, and at least this should
219     -- catch them all.
220     -- Only on exported things
221   | dopt Opt_AutoSccsOnExportedToplevs dflags
222   = AddSccs mod (\id -> idName id `elemNameSet` exports)
223   | otherwise
224   = NoSccs
225
226 deSugarExpr :: HscEnv
227             -> Module -> GlobalRdrEnv -> TypeEnv 
228             -> LHsExpr Id
229             -> IO (Messages, Maybe CoreExpr)
230 -- Prints its own errors; returns Nothing if error occurred
231
232 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
233     let dflags = hsc_dflags hsc_env
234     showPass dflags "Desugar"
235
236     -- Do desugaring
237     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
238                                    dsLExpr tc_expr
239
240     case mb_core_expr of
241       Nothing   -> return (msgs, Nothing)
242       Just expr -> do
243
244         -- Dump output
245         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
246
247         return (msgs, Just expr)
248 \end{code}
249
250 %************************************************************************
251 %*                                                                      *
252 %*              Add rules and export flags to binders
253 %*                                                                      *
254 %************************************************************************
255
256 \begin{code}
257 addExportFlagsAndRules 
258     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
259     -> [(Id, t)] -> [(Id, t)]
260 addExportFlagsAndRules target exports keep_alive rules prs
261   = mapFst add_one prs
262   where
263     add_one bndr = add_rules name (add_export name bndr)
264        where
265          name = idName bndr
266
267     ---------- Rules --------
268         -- See Note [Attach rules to local ids]
269         -- NB: the binder might have some existing rules,
270         -- arising from specialisation pragmas
271     add_rules name bndr
272         | Just rules <- lookupNameEnv rule_base name
273         = bndr `addIdSpecialisations` rules
274         | otherwise
275         = bndr
276     rule_base = extendRuleBaseList emptyRuleBase rules
277
278     ---------- Export flag --------
279     -- See Note [Adding export flags]
280     add_export name bndr
281         | dont_discard name = setIdExported bndr
282         | otherwise         = bndr
283
284     dont_discard :: Name -> Bool
285     dont_discard name = is_exported name
286                      || name `elemNameSet` keep_alive
287
288         -- In interactive mode, we don't want to discard any top-level
289         -- entities at all (eg. do not inline them away during
290         -- simplification), and retain them all in the TypeEnv so they are
291         -- available from the command line.
292         --
293         -- isExternalName separates the user-defined top-level names from those
294         -- introduced by the type checker.
295     is_exported :: Name -> Bool
296     is_exported | target == HscInterpreted = isExternalName
297                 | otherwise                = (`elemNameSet` exports)
298 \end{code}
299
300
301 Note [Adding export flags]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Set the no-discard flag if either 
304         a) the Id is exported
305         b) it's mentioned in the RHS of an orphan rule
306         c) it's in the keep-alive set
307
308 It means that the binding won't be discarded EVEN if the binding
309 ends up being trivial (v = w) -- the simplifier would usually just 
310 substitute w for v throughout, but we don't apply the substitution to
311 the rules (maybe we should?), so this substitution would make the rule
312 bogus.
313
314 You might wonder why exported Ids aren't already marked as such;
315 it's just because the type checker is rather busy already and
316 I didn't want to pass in yet another mapping.
317
318 Note [Attach rules to local ids]
319 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
320 Find the rules for locally-defined Ids; then we can attach them
321 to the binders in the top-level bindings
322
323 Reason
324   - It makes the rules easier to look up
325   - It means that transformation rules and specialisations for
326     locally defined Ids are handled uniformly
327   - It keeps alive things that are referred to only from a rule
328     (the occurrence analyser knows about rules attached to Ids)
329   - It makes sure that, when we apply a rule, the free vars
330     of the RHS are more likely to be in scope
331   - The imported rules are carried in the in-scope set
332     which is extended on each iteration by the new wave of
333     local binders; any rules which aren't on the binding will
334     thereby get dropped
335
336
337 %************************************************************************
338 %*                                                                      *
339 %*              Desugaring transformation rules
340 %*                                                                      *
341 %************************************************************************
342
343 \begin{code}
344 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
345 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
346   = putSrcSpanDs loc $ 
347     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
348
349         ; lhs' <- unsetDOptM Opt_EnableRewriteRules $
350                   unsetWOptM Opt_WarnIdentities $
351                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
352
353         ; rhs' <- dsLExpr rhs
354
355         -- Substitute the dict bindings eagerly,
356         -- and take the body apart into a (f args) form
357         ; case decomposeRuleLhs bndrs' lhs' of {
358                 Left msg -> do { warnDs msg; return Nothing } ;
359                 Right (final_bndrs, fn_id, args) -> do
360         
361         { let is_local = isLocalId fn_id
362                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
363                 -- we don't want to attach rules to the bindings of implicit Ids, 
364                 -- because they don't show up in the bindings until just before code gen
365               fn_name   = idName fn_id
366               final_rhs = simpleOptExpr rhs'    -- De-crap it
367               rule      = mkRule False {- Not auto -} is_local 
368                                  name act fn_name final_bndrs args final_rhs
369         ; return (Just rule)
370         } } }
371 \end{code}
372
373 Note [Desugaring RULE left hand sides]
374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
375 For the LHS of a RULE we do *not* want to desugar
376     [x]   to    build (\cn. x `c` n)
377 We want to leave explicit lists simply as chains
378 of cons's. We can achieve that slightly indirectly by
379 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
380
381 That keeps the desugaring of list comprehensions simple too.
382
383
384
385 Nor do we want to warn of conversion identities on the LHS;
386 the rule is precisly to optimise them:
387   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
388
389
390 %************************************************************************
391 %*                                                                      *
392 %*              Desugaring vectorisation declarations
393 %*                                                                      *
394 %************************************************************************
395
396 \begin{code}
397 dsVect :: LVectDecl Id -> DsM CoreVect
398 dsVect (L loc (HsVect (L _ v) rhs))
399   = putSrcSpanDs loc $ 
400     do { rhs' <- fmapMaybeM dsLExpr rhs
401        ; return $ Vect v rhs'
402            }
403 dsVect (L _loc (HsNoVect (L _ v)))
404   = return $ NoVect v
405 \end{code}