2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The Desugarer: turning HsSyn into Core.
9 module Desugar ( deSugar, deSugarExpr ) where
26 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
27 -- depends on DsExpr.hi-boot.
33 import CoreMonad ( endPass, CoreToDo(..) )
45 %************************************************************************
47 %* The main function: deSugar
49 %************************************************************************
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
58 tcg_env@(TcGblEnv { tcg_mod = mod,
60 tcg_type_env = type_env,
61 tcg_imports = imports,
62 tcg_exports = exports,
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,
71 tcg_imp_specs = imp_specs,
72 tcg_ev_binds = ev_binds,
76 tcg_fam_insts = fam_insts,
77 tcg_hpc = other_hpc_info })
79 = do { let dflags = hsc_dflags hsc_env
80 ; showPass dflags "Desugar"
82 -- Desugar the program
83 ; let export_set = availsToNameSet exports
84 ; let auto_scc = mkAutoScc dflags mod export_set
85 ; let target = hscTarget dflags
86 ; let hpcInfo = emptyHpcInfo other_hpc_info
90 return (emptyMessages,
91 Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
93 (binds_cvr,ds_hpc_info, modBreaks)
95 || target == HscInterpreted)
96 && (not (isHsBoot hsc_src))
97 then addCoverageTicksToBinds dflags mod mod_loc
98 (typeEnvTyCons type_env) binds
99 else return (binds, hpcInfo, emptyModBreaks)
100 initDs hsc_env mod rdr_env type_env $ do
101 do { ds_ev_binds <- dsEvBinds ev_binds
102 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
103 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
104 ; (ds_fords, foreign_prs) <- dsForeigns fords
105 ; rules <- mapMaybeM dsRule rules
106 ; return ( ds_ev_binds
107 , foreign_prs `appOL` core_prs `appOL` spec_prs
108 , spec_rules ++ rules
109 , ds_fords, ds_hpc_info, modBreaks) }
112 Nothing -> return (msgs, Nothing) ;
113 Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
115 { -- Add export flags to bindings
116 keep_alive <- readIORef keep_var
117 ; let (rules_for_locals, rules_for_imps)
118 = partition isLocalRule all_rules
119 final_prs = addExportFlagsAndRules target
120 export_set keep_alive rules_for_locals (fromOL all_prs)
122 final_pgm = combineEvBinds ds_ev_binds final_prs
123 -- Notice that we put the whole lot in a big Rec, even the foreign binds
124 -- When compiling PrelFloat, which defines data Float = F# Float#
125 -- we want F# to be in scope in the foreign marshalling code!
126 -- You might think it doesn't matter, but the simplifier brings all top-level
127 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
129 -- Lint result if necessary, and print
130 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
131 (vcat [ pprCoreBindings final_pgm
132 , pprRules rules_for_imps ])
134 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
135 -- The simpleOptPgm gets rid of type
136 -- bindings plus any stupid dead code
138 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
140 ; let used_names = mkUsedNames tcg_env
141 ; deps <- mkDependencies tcg_env
143 ; let mod_guts = ModGuts {
145 mg_boot = isHsBoot hsc_src,
146 mg_exports = exports,
148 mg_used_names = used_names,
149 mg_dir_imps = imp_mods imports,
150 mg_rdr_env = rdr_env,
151 mg_fix_env = fix_env,
156 mg_fam_insts = fam_insts,
157 mg_inst_env = inst_env,
158 mg_fam_inst_env = fam_inst_env,
159 mg_rules = ds_rules_for_imps,
161 mg_foreign = ds_fords,
162 mg_hpc_info = ds_hpc_info,
163 mg_modBreaks = modBreaks,
164 mg_vect_info = noVectInfo
166 ; return (msgs, Just mod_guts)
169 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
171 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
172 ; let (spec_binds, spec_rules) = unzip spec_prs
173 ; return (concatOL spec_binds, spec_rules) }
175 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
176 -- Top-level bindings can include coercion bindings, but not via superclasses
177 -- See Note [Top-level evidence]
178 combineEvBinds [] val_prs
180 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
181 | isId b = combineEvBinds bs ((b,r):val_prs)
182 | otherwise = NonRec b r : combineEvBinds bs val_prs
183 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
184 = combineEvBinds bs (prs ++ val_prs)
185 combineEvBinds (CaseEvBind x _ _ : _) _
186 = pprPanic "topEvBindPairs" (ppr x)
189 Note [Top-level evidence]
190 ~~~~~~~~~~~~~~~~~~~~~~~~~
191 Top-level evidence bindings may be mutually recursive with the top-level value
192 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
193 because the occurrence analyser doesn't teke account of type/coercion variables
194 when computing dependencies.
196 So we pull out the type/coercion variables (which are in dependency order),
201 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
202 mkAutoScc dflags mod exports
203 | not opt_SccProfilingOn -- No profiling
205 -- Add auto-scc on all top-level things
206 | dopt Opt_AutoSccsOnAllToplevs dflags
207 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
208 -- See #1641. This is pretty yucky, but I can't see a better way
209 -- to identify compiler-generated Ids, and at least this should
211 -- Only on exported things
212 | dopt Opt_AutoSccsOnExportedToplevs dflags
213 = AddSccs mod (\id -> idName id `elemNameSet` exports)
217 deSugarExpr :: HscEnv
218 -> Module -> GlobalRdrEnv -> TypeEnv
220 -> IO (Messages, Maybe CoreExpr)
221 -- Prints its own errors; returns Nothing if error occurred
223 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
224 let dflags = hsc_dflags hsc_env
225 showPass dflags "Desugar"
228 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
232 Nothing -> return (msgs, Nothing)
236 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
238 return (msgs, Just expr)
241 %************************************************************************
243 %* Add rules and export flags to binders
245 %************************************************************************
248 addExportFlagsAndRules
249 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
250 -> [(Id, t)] -> [(Id, t)]
251 addExportFlagsAndRules target exports keep_alive rules prs
254 add_one bndr = add_rules name (add_export name bndr)
258 ---------- Rules --------
259 -- See Note [Attach rules to local ids]
260 -- NB: the binder might have some existing rules,
261 -- arising from specialisation pragmas
263 | Just rules <- lookupNameEnv rule_base name
264 = bndr `addIdSpecialisations` rules
267 rule_base = extendRuleBaseList emptyRuleBase rules
269 ---------- Export flag --------
270 -- See Note [Adding export flags]
272 | dont_discard name = setIdExported bndr
275 dont_discard :: Name -> Bool
276 dont_discard name = is_exported name
277 || name `elemNameSet` keep_alive
279 -- In interactive mode, we don't want to discard any top-level
280 -- entities at all (eg. do not inline them away during
281 -- simplification), and retain them all in the TypeEnv so they are
282 -- available from the command line.
284 -- isExternalName separates the user-defined top-level names from those
285 -- introduced by the type checker.
286 is_exported :: Name -> Bool
287 is_exported | target == HscInterpreted = isExternalName
288 | otherwise = (`elemNameSet` exports)
292 Note [Adding export flags]
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~
294 Set the no-discard flag if either
295 a) the Id is exported
296 b) it's mentioned in the RHS of an orphan rule
297 c) it's in the keep-alive set
299 It means that the binding won't be discarded EVEN if the binding
300 ends up being trivial (v = w) -- the simplifier would usually just
301 substitute w for v throughout, but we don't apply the substitution to
302 the rules (maybe we should?), so this substitution would make the rule
305 You might wonder why exported Ids aren't already marked as such;
306 it's just because the type checker is rather busy already and
307 I didn't want to pass in yet another mapping.
309 Note [Attach rules to local ids]
310 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
311 Find the rules for locally-defined Ids; then we can attach them
312 to the binders in the top-level bindings
315 - It makes the rules easier to look up
316 - It means that transformation rules and specialisations for
317 locally defined Ids are handled uniformly
318 - It keeps alive things that are referred to only from a rule
319 (the occurrence analyser knows about rules attached to Ids)
320 - It makes sure that, when we apply a rule, the free vars
321 of the RHS are more likely to be in scope
322 - The imported rules are carried in the in-scope set
323 which is extended on each iteration by the new wave of
324 local binders; any rules which aren't on the binding will
328 %************************************************************************
330 %* Desugaring transformation rules
332 %************************************************************************
335 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
336 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
338 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
340 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
341 unsetOptM Opt_WarnIdentities $
342 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
344 ; rhs' <- dsLExpr rhs
346 -- Substitute the dict bindings eagerly,
347 -- and take the body apart into a (f args) form
348 ; case decomposeRuleLhs bndrs' lhs' of {
349 Left msg -> do { warnDs msg; return Nothing } ;
350 Right (final_bndrs, fn_id, args) -> do
352 { let is_local = isLocalId fn_id
353 -- NB: isLocalId is False of implicit Ids. This is good becuase
354 -- we don't want to attach rules to the bindings of implicit Ids,
355 -- because they don't show up in the bindings until just before code gen
356 fn_name = idName fn_id
357 final_rhs = simpleOptExpr rhs' -- De-crap it
358 rule = mkRule False {- Not auto -} is_local
359 name act fn_name final_bndrs args final_rhs
364 Note [Desugaring RULE left hand sides]
365 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
366 For the LHS of a RULE we do *not* want to desugar
367 [x] to build (\cn. x `c` n)
368 We want to leave explicit lists simply as chains
369 of cons's. We can achieve that slightly indirectly by
370 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
372 That keeps the desugaring of list comprehensions simple too.
374 Nor do we want to warn of conversion identities on the LHS;
375 the rule is precisly to optimise them:
376 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}