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(..) )
46 %************************************************************************
48 %* The main function: deSugar
50 %************************************************************************
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
59 tcg_env@(TcGblEnv { tcg_mod = mod,
61 tcg_type_env = type_env,
62 tcg_imports = imports,
63 tcg_exports = exports,
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,
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 ([], [], [], 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 ds_ev_binds <- dsEvBinds ev_binds
102 core_prs <- dsTopLHsBinds auto_scc binds_cvr
103 (ds_fords, foreign_prs) <- dsForeigns fords
104 let all_prs = foreign_prs ++ core_prs
105 mb_rules <- mapM dsRule rules
106 return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks)
109 Nothing -> return (msgs, Nothing) ;
110 Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do
112 { -- Add export flags to bindings
113 keep_alive <- readIORef keep_var
114 ; let (rules_for_locals, rules_for_imps)
115 = partition isLocalRule (catMaybes mb_rules)
116 final_prs = addExportFlagsAndRules target
117 export_set keep_alive rules_for_locals all_prs
119 final_pgm = combineEvBinds ds_ev_binds final_prs
120 -- Notice that we put the whole lot in a big Rec, even the foreign binds
121 -- When compiling PrelFloat, which defines data Float = F# Float#
122 -- we want F# to be in scope in the foreign marshalling code!
123 -- You might think it doesn't matter, but the simplifier brings all top-level
124 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
126 -- Lint result if necessary, and print
127 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
128 (vcat [ pprCoreBindings final_pgm
129 , pprRules rules_for_imps ])
131 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
132 -- The simpleOptPgm gets rid of type
133 -- bindings plus any stupid dead code
135 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
137 ; used_names <- mkUsedNames tcg_env
138 ; deps <- mkDependencies tcg_env
140 ; let mod_guts = ModGuts {
142 mg_boot = isHsBoot hsc_src,
143 mg_exports = exports,
145 mg_used_names = used_names,
146 mg_dir_imps = imp_mods imports,
147 mg_rdr_env = rdr_env,
148 mg_fix_env = fix_env,
153 mg_fam_insts = fam_insts,
154 mg_inst_env = inst_env,
155 mg_fam_inst_env = fam_inst_env,
156 mg_rules = ds_rules_for_imps,
158 mg_foreign = ds_fords,
159 mg_hpc_info = ds_hpc_info,
160 mg_modBreaks = modBreaks,
161 mg_vect_info = noVectInfo
163 ; return (msgs, Just mod_guts)
167 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
168 -- Top-level bindings can include coercion bindings, but not via superclasses
169 -- See Note [Top-level evidence]
170 combineEvBinds [] val_prs
172 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
173 | isId b = combineEvBinds bs ((b,r):val_prs)
174 | otherwise = NonRec b r : combineEvBinds bs val_prs
175 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
176 = combineEvBinds bs (prs ++ val_prs)
177 combineEvBinds (CaseEvBind x _ _ : _) _
178 = pprPanic "topEvBindPairs" (ppr x)
181 Note [Top-level evidence]
182 ~~~~~~~~~~~~~~~~~~~~~~~~~
183 Top-level evidence bindings may be mutually recursive with the top-level value
184 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
185 because the occurrence analyser doesn't teke account of type/coercion variables
186 when computing dependencies.
188 So we pull out the type/coercion variables (which are in dependency order),
193 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
194 mkAutoScc dflags mod exports
195 | not opt_SccProfilingOn -- No profiling
197 -- Add auto-scc on all top-level things
198 | dopt Opt_AutoSccsOnAllToplevs dflags
199 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
200 -- See #1641. This is pretty yucky, but I can't see a better way
201 -- to identify compiler-generated Ids, and at least this should
203 -- Only on exported things
204 | dopt Opt_AutoSccsOnExportedToplevs dflags
205 = AddSccs mod (\id -> idName id `elemNameSet` exports)
209 deSugarExpr :: HscEnv
210 -> Module -> GlobalRdrEnv -> TypeEnv
212 -> IO (Messages, Maybe CoreExpr)
213 -- Prints its own errors; returns Nothing if error occurred
215 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
216 let dflags = hsc_dflags hsc_env
217 showPass dflags "Desugar"
220 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
224 Nothing -> return (msgs, Nothing)
228 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
230 return (msgs, Just expr)
233 %************************************************************************
235 %* Add rules and export flags to binders
237 %************************************************************************
240 addExportFlagsAndRules
241 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
242 -> [(Id, t)] -> [(Id, t)]
243 addExportFlagsAndRules target exports keep_alive rules prs
246 add_one bndr = add_rules name (add_export name bndr)
250 ---------- Rules --------
251 -- See Note [Attach rules to local ids]
252 -- NB: the binder might have some existing rules,
253 -- arising from specialisation pragmas
255 | Just rules <- lookupNameEnv rule_base name
256 = bndr `addIdSpecialisations` rules
259 rule_base = extendRuleBaseList emptyRuleBase rules
261 ---------- Export flag --------
262 -- See Note [Adding export flags]
264 | dont_discard name = setIdExported bndr
267 dont_discard :: Name -> Bool
268 dont_discard name = is_exported name
269 || name `elemNameSet` keep_alive
271 -- In interactive mode, we don't want to discard any top-level
272 -- entities at all (eg. do not inline them away during
273 -- simplification), and retain them all in the TypeEnv so they are
274 -- available from the command line.
276 -- isExternalName separates the user-defined top-level names from those
277 -- introduced by the type checker.
278 is_exported :: Name -> Bool
279 is_exported | target == HscInterpreted = isExternalName
280 | otherwise = (`elemNameSet` exports)
284 Note [Adding export flags]
285 ~~~~~~~~~~~~~~~~~~~~~~~~~~
286 Set the no-discard flag if either
287 a) the Id is exported
288 b) it's mentioned in the RHS of an orphan rule
289 c) it's in the keep-alive set
291 It means that the binding won't be discarded EVEN if the binding
292 ends up being trivial (v = w) -- the simplifier would usually just
293 substitute w for v throughout, but we don't apply the substitution to
294 the rules (maybe we should?), so this substitution would make the rule
297 You might wonder why exported Ids aren't already marked as such;
298 it's just because the type checker is rather busy already and
299 I didn't want to pass in yet another mapping.
301 Note [Attach rules to local ids]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Find the rules for locally-defined Ids; then we can attach them
304 to the binders in the top-level bindings
307 - It makes the rules easier to look up
308 - It means that transformation rules and specialisations for
309 locally defined Ids are handled uniformly
310 - It keeps alive things that are referred to only from a rule
311 (the occurrence analyser knows about rules attached to Ids)
312 - It makes sure that, when we apply a rule, the free vars
313 of the RHS are more likely to be in scope
314 - The imported rules are carried in the in-scope set
315 which is extended on each iteration by the new wave of
316 local binders; any rules which aren't on the binding will
320 %************************************************************************
322 %* Desugaring transformation rules
324 %************************************************************************
327 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
328 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
330 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
332 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
333 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
335 ; rhs' <- dsLExpr rhs
337 -- Substitute the dict bindings eagerly,
338 -- and take the body apart into a (f args) form
339 ; case decomposeRuleLhs lhs' of {
340 Nothing -> do { warnDs msg; return Nothing } ;
341 Just (fn_id, args) -> do
343 { let local_rule = isLocalId fn_id
344 -- NB: isLocalId is False of implicit Ids. This is good becuase
345 -- we don't want to attach rules to the bindings of implicit Ids,
346 -- because they don't show up in the bindings until just before code gen
347 fn_name = idName fn_id
348 final_rhs = simpleOptExpr rhs' -- De-crap it
349 rule = mkRule local_rule name act fn_name bndrs' args final_rhs
353 msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
357 Note [Desugaring RULE left hand sides]
358 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
359 For the LHS of a RULE we do *not* want to desugar
360 [x] to build (\cn. x `c` n)
361 We want to leave explicit lists simply as chains
362 of cons's. We can achieve that slightly indirectly by
363 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
365 That keeps the desugaring of list comprehensions simple too.