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,
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 ; ds_rules <- mapMaybeM dsRule rules
107 ; ds_vects <- mapM dsVect vects
109 | opt_Hpc = hpcInitCode mod ds_hpc_info
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) }
118 Nothing -> return (msgs, Nothing) ;
119 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
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)
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#!
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 ])
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
145 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
147 ; let used_names = mkUsedNames tcg_env
148 ; deps <- mkDependencies tcg_env
150 ; let mod_guts = ModGuts {
152 mg_boot = isHsBoot hsc_src,
153 mg_exports = exports,
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,
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,
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
174 ; return (msgs, Just mod_guts)
177 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
179 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
180 ; let (spec_binds, spec_rules) = unzip spec_prs
181 ; return (concatOL spec_binds, spec_rules) }
183 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
184 -- Top-level bindings can include coercion bindings, but not via superclasses
185 -- See Note [Top-level evidence]
186 combineEvBinds [] val_prs
188 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
189 | isId b = combineEvBinds bs ((b,r):val_prs)
190 | otherwise = NonRec b r : combineEvBinds bs val_prs
191 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
192 = combineEvBinds bs (prs ++ val_prs)
193 combineEvBinds (CaseEvBind x _ _ : _) _
194 = pprPanic "topEvBindPairs" (ppr x)
197 Note [Top-level evidence]
198 ~~~~~~~~~~~~~~~~~~~~~~~~~
199 Top-level evidence bindings may be mutually recursive with the top-level value
200 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
201 because the occurrence analyser doesn't teke account of type/coercion variables
202 when computing dependencies.
204 So we pull out the type/coercion variables (which are in dependency order),
209 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
210 mkAutoScc dflags mod exports
211 | not opt_SccProfilingOn -- No profiling
213 -- Add auto-scc on all top-level things
214 | dopt Opt_AutoSccsOnAllToplevs dflags
215 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
216 -- See #1641. This is pretty yucky, but I can't see a better way
217 -- to identify compiler-generated Ids, and at least this should
219 -- Only on exported things
220 | dopt Opt_AutoSccsOnExportedToplevs dflags
221 = AddSccs mod (\id -> idName id `elemNameSet` exports)
225 deSugarExpr :: HscEnv
226 -> Module -> GlobalRdrEnv -> TypeEnv
228 -> IO (Messages, Maybe CoreExpr)
229 -- Prints its own errors; returns Nothing if error occurred
231 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
232 let dflags = hsc_dflags hsc_env
233 showPass dflags "Desugar"
236 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
240 Nothing -> return (msgs, Nothing)
244 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
246 return (msgs, Just expr)
249 %************************************************************************
251 %* Add rules and export flags to binders
253 %************************************************************************
256 addExportFlagsAndRules
257 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
258 -> [(Id, t)] -> [(Id, t)]
259 addExportFlagsAndRules target exports keep_alive rules prs
262 add_one bndr = add_rules name (add_export name bndr)
266 ---------- Rules --------
267 -- See Note [Attach rules to local ids]
268 -- NB: the binder might have some existing rules,
269 -- arising from specialisation pragmas
271 | Just rules <- lookupNameEnv rule_base name
272 = bndr `addIdSpecialisations` rules
275 rule_base = extendRuleBaseList emptyRuleBase rules
277 ---------- Export flag --------
278 -- See Note [Adding export flags]
280 | dont_discard name = setIdExported bndr
283 dont_discard :: Name -> Bool
284 dont_discard name = is_exported name
285 || name `elemNameSet` keep_alive
287 -- In interactive mode, we don't want to discard any top-level
288 -- entities at all (eg. do not inline them away during
289 -- simplification), and retain them all in the TypeEnv so they are
290 -- available from the command line.
292 -- isExternalName separates the user-defined top-level names from those
293 -- introduced by the type checker.
294 is_exported :: Name -> Bool
295 is_exported | target == HscInterpreted = isExternalName
296 | otherwise = (`elemNameSet` exports)
300 Note [Adding export flags]
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~
302 Set the no-discard flag if either
303 a) the Id is exported
304 b) it's mentioned in the RHS of an orphan rule
305 c) it's in the keep-alive set
307 It means that the binding won't be discarded EVEN if the binding
308 ends up being trivial (v = w) -- the simplifier would usually just
309 substitute w for v throughout, but we don't apply the substitution to
310 the rules (maybe we should?), so this substitution would make the rule
313 You might wonder why exported Ids aren't already marked as such;
314 it's just because the type checker is rather busy already and
315 I didn't want to pass in yet another mapping.
317 Note [Attach rules to local ids]
318 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
319 Find the rules for locally-defined Ids; then we can attach them
320 to the binders in the top-level bindings
323 - It makes the rules easier to look up
324 - It means that transformation rules and specialisations for
325 locally defined Ids are handled uniformly
326 - It keeps alive things that are referred to only from a rule
327 (the occurrence analyser knows about rules attached to Ids)
328 - It makes sure that, when we apply a rule, the free vars
329 of the RHS are more likely to be in scope
330 - The imported rules are carried in the in-scope set
331 which is extended on each iteration by the new wave of
332 local binders; any rules which aren't on the binding will
336 %************************************************************************
338 %* Desugaring transformation rules
340 %************************************************************************
343 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
344 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
346 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
348 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
349 unsetOptM Opt_WarnIdentities $
350 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
352 ; rhs' <- dsLExpr rhs
354 -- Substitute the dict bindings eagerly,
355 -- and take the body apart into a (f args) form
356 ; case decomposeRuleLhs bndrs' lhs' of {
357 Left msg -> do { warnDs msg; return Nothing } ;
358 Right (final_bndrs, fn_id, args) -> do
360 { let is_local = isLocalId fn_id
361 -- NB: isLocalId is False of implicit Ids. This is good becuase
362 -- we don't want to attach rules to the bindings of implicit Ids,
363 -- because they don't show up in the bindings until just before code gen
364 fn_name = idName fn_id
365 final_rhs = simpleOptExpr rhs' -- De-crap it
366 rule = mkRule False {- Not auto -} is_local
367 name act fn_name final_bndrs args final_rhs
372 Note [Desugaring RULE left hand sides]
373 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 For the LHS of a RULE we do *not* want to desugar
375 [x] to build (\cn. x `c` n)
376 We want to leave explicit lists simply as chains
377 of cons's. We can achieve that slightly indirectly by
378 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
380 That keeps the desugaring of list comprehensions simple too.
384 Nor do we want to warn of conversion identities on the LHS;
385 the rule is precisly to optimise them:
386 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
389 %************************************************************************
391 %* Desugaring vectorisation declarations
393 %************************************************************************
396 dsVect :: LVectDecl Id -> DsM CoreVect
397 dsVect (L loc (HsVect v rhs))
399 do { rhs' <- fmapMaybeM dsLExpr rhs
400 ; return $ Vect (unLoc v) rhs'
402 -- dsVect (L loc (HsVect v Nothing))
403 -- = return $ Vect v Nothing
404 -- dsVect (L loc (HsVect v (Just rhs)))
405 -- = putSrcSpanDs loc $
406 -- do { rhs' <- dsLExpr rhs
407 -- ; return $ Vect v (Just rhs')