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_imp_specs = imp_specs,
73 tcg_ev_binds = ev_binds,
77 tcg_fam_insts = fam_insts,
78 tcg_hpc = other_hpc_info })
80 = do { let dflags = hsc_dflags hsc_env
81 ; showPass dflags "Desugar"
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
91 return (emptyMessages,
92 Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
94 (binds_cvr,ds_hpc_info, modBreaks)
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 ; rules <- mapMaybeM dsRule rules
107 ; return ( ds_ev_binds
108 , foreign_prs `appOL` core_prs `appOL` spec_prs
109 , spec_rules ++ rules
110 , ds_fords, ds_hpc_info, modBreaks) }
113 Nothing -> return (msgs, Nothing) ;
114 Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
116 { -- Add export flags to bindings
117 keep_alive <- readIORef keep_var
118 ; let (rules_for_locals, rules_for_imps)
119 = partition isLocalRule all_rules
120 final_prs = addExportFlagsAndRules target
121 export_set keep_alive rules_for_locals (fromOL all_prs)
123 final_pgm = combineEvBinds ds_ev_binds final_prs
124 -- Notice that we put the whole lot in a big Rec, even the foreign binds
125 -- When compiling PrelFloat, which defines data Float = F# Float#
126 -- we want F# to be in scope in the foreign marshalling code!
127 -- You might think it doesn't matter, but the simplifier brings all top-level
128 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
130 -- Lint result if necessary, and print
131 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
132 (vcat [ pprCoreBindings final_pgm
133 , pprRules rules_for_imps ])
135 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
136 -- The simpleOptPgm gets rid of type
137 -- bindings plus any stupid dead code
139 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
141 ; used_names <- mkUsedNames tcg_env
142 ; deps <- mkDependencies tcg_env
144 ; let mod_guts = ModGuts {
146 mg_boot = isHsBoot hsc_src,
147 mg_exports = exports,
149 mg_used_names = used_names,
150 mg_dir_imps = imp_mods imports,
151 mg_rdr_env = rdr_env,
152 mg_fix_env = fix_env,
157 mg_fam_insts = fam_insts,
158 mg_inst_env = inst_env,
159 mg_fam_inst_env = fam_inst_env,
160 mg_rules = ds_rules_for_imps,
162 mg_foreign = ds_fords,
163 mg_hpc_info = ds_hpc_info,
164 mg_modBreaks = modBreaks,
165 mg_vect_info = noVectInfo
167 ; return (msgs, Just mod_guts)
170 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
172 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
173 ; let (spec_binds, spec_rules) = unzip spec_prs
174 ; return (concatOL spec_binds, spec_rules) }
176 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
177 -- Top-level bindings can include coercion bindings, but not via superclasses
178 -- See Note [Top-level evidence]
179 combineEvBinds [] val_prs
181 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
182 | isId b = combineEvBinds bs ((b,r):val_prs)
183 | otherwise = NonRec b r : combineEvBinds bs val_prs
184 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
185 = combineEvBinds bs (prs ++ val_prs)
186 combineEvBinds (CaseEvBind x _ _ : _) _
187 = pprPanic "topEvBindPairs" (ppr x)
190 Note [Top-level evidence]
191 ~~~~~~~~~~~~~~~~~~~~~~~~~
192 Top-level evidence bindings may be mutually recursive with the top-level value
193 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
194 because the occurrence analyser doesn't teke account of type/coercion variables
195 when computing dependencies.
197 So we pull out the type/coercion variables (which are in dependency order),
202 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
203 mkAutoScc dflags mod exports
204 | not opt_SccProfilingOn -- No profiling
206 -- Add auto-scc on all top-level things
207 | dopt Opt_AutoSccsOnAllToplevs dflags
208 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
209 -- See #1641. This is pretty yucky, but I can't see a better way
210 -- to identify compiler-generated Ids, and at least this should
212 -- Only on exported things
213 | dopt Opt_AutoSccsOnExportedToplevs dflags
214 = AddSccs mod (\id -> idName id `elemNameSet` exports)
218 deSugarExpr :: HscEnv
219 -> Module -> GlobalRdrEnv -> TypeEnv
221 -> IO (Messages, Maybe CoreExpr)
222 -- Prints its own errors; returns Nothing if error occurred
224 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
225 let dflags = hsc_dflags hsc_env
226 showPass dflags "Desugar"
229 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
233 Nothing -> return (msgs, Nothing)
237 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
239 return (msgs, Just expr)
242 %************************************************************************
244 %* Add rules and export flags to binders
246 %************************************************************************
249 addExportFlagsAndRules
250 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
251 -> [(Id, t)] -> [(Id, t)]
252 addExportFlagsAndRules target exports keep_alive rules prs
255 add_one bndr = add_rules name (add_export name bndr)
259 ---------- Rules --------
260 -- See Note [Attach rules to local ids]
261 -- NB: the binder might have some existing rules,
262 -- arising from specialisation pragmas
264 | Just rules <- lookupNameEnv rule_base name
265 = bndr `addIdSpecialisations` rules
268 rule_base = extendRuleBaseList emptyRuleBase rules
270 ---------- Export flag --------
271 -- See Note [Adding export flags]
273 | dont_discard name = setIdExported bndr
276 dont_discard :: Name -> Bool
277 dont_discard name = is_exported name
278 || name `elemNameSet` keep_alive
280 -- In interactive mode, we don't want to discard any top-level
281 -- entities at all (eg. do not inline them away during
282 -- simplification), and retain them all in the TypeEnv so they are
283 -- available from the command line.
285 -- isExternalName separates the user-defined top-level names from those
286 -- introduced by the type checker.
287 is_exported :: Name -> Bool
288 is_exported | target == HscInterpreted = isExternalName
289 | otherwise = (`elemNameSet` exports)
293 Note [Adding export flags]
294 ~~~~~~~~~~~~~~~~~~~~~~~~~~
295 Set the no-discard flag if either
296 a) the Id is exported
297 b) it's mentioned in the RHS of an orphan rule
298 c) it's in the keep-alive set
300 It means that the binding won't be discarded EVEN if the binding
301 ends up being trivial (v = w) -- the simplifier would usually just
302 substitute w for v throughout, but we don't apply the substitution to
303 the rules (maybe we should?), so this substitution would make the rule
306 You might wonder why exported Ids aren't already marked as such;
307 it's just because the type checker is rather busy already and
308 I didn't want to pass in yet another mapping.
310 Note [Attach rules to local ids]
311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
312 Find the rules for locally-defined Ids; then we can attach them
313 to the binders in the top-level bindings
316 - It makes the rules easier to look up
317 - It means that transformation rules and specialisations for
318 locally defined Ids are handled uniformly
319 - It keeps alive things that are referred to only from a rule
320 (the occurrence analyser knows about rules attached to Ids)
321 - It makes sure that, when we apply a rule, the free vars
322 of the RHS are more likely to be in scope
323 - The imported rules are carried in the in-scope set
324 which is extended on each iteration by the new wave of
325 local binders; any rules which aren't on the binding will
329 %************************************************************************
331 %* Desugaring transformation rules
333 %************************************************************************
336 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
337 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
339 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
341 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
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 lhs' of {
349 Nothing -> do { warnDs msg; return Nothing } ;
350 Just (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 bndrs' args final_rhs
363 msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
367 Note [Desugaring RULE left hand sides]
368 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
369 For the LHS of a RULE we do *not* want to desugar
370 [x] to build (\cn. x `c` n)
371 We want to leave explicit lists simply as chains
372 of cons's. We can achieve that slightly indirectly by
373 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
375 That keeps the desugaring of list comprehensions simple too.