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