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, ds_vects, 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) <- simpleOptPgm dflags final_pgm rules_for_imps
141 -- The simpleOptPgm gets rid of type
142 -- bindings plus any stupid dead code
144 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
146 ; let used_names = mkUsedNames tcg_env
147 ; deps <- mkDependencies tcg_env
149 ; let mod_guts = ModGuts {
151 mg_boot = isHsBoot hsc_src,
152 mg_exports = exports,
154 mg_used_names = used_names,
155 mg_dir_imps = imp_mods imports,
156 mg_rdr_env = rdr_env,
157 mg_fix_env = fix_env,
162 mg_fam_insts = fam_insts,
163 mg_inst_env = inst_env,
164 mg_fam_inst_env = fam_inst_env,
165 mg_rules = ds_rules_for_imps,
167 mg_foreign = ds_fords,
168 mg_hpc_info = ds_hpc_info,
169 mg_modBreaks = modBreaks,
170 mg_vect_decls = ds_vects,
171 mg_vect_info = noVectInfo
173 ; return (msgs, Just mod_guts)
176 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
178 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
179 ; let (spec_binds, spec_rules) = unzip spec_prs
180 ; return (concatOL spec_binds, spec_rules) }
182 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
183 -- Top-level bindings can include coercion bindings, but not via superclasses
184 -- See Note [Top-level evidence]
185 combineEvBinds [] val_prs
187 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
188 | isId b = combineEvBinds bs ((b,r):val_prs)
189 | otherwise = NonRec b r : combineEvBinds bs val_prs
190 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
191 = combineEvBinds bs (prs ++ val_prs)
192 combineEvBinds (CaseEvBind x _ _ : _) _
193 = pprPanic "topEvBindPairs" (ppr x)
196 Note [Top-level evidence]
197 ~~~~~~~~~~~~~~~~~~~~~~~~~
198 Top-level evidence bindings may be mutually recursive with the top-level value
199 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
200 because the occurrence analyser doesn't teke account of type/coercion variables
201 when computing dependencies.
203 So we pull out the type/coercion variables (which are in dependency order),
208 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
209 mkAutoScc dflags mod exports
210 | not opt_SccProfilingOn -- No profiling
212 -- Add auto-scc on all top-level things
213 | dopt Opt_AutoSccsOnAllToplevs dflags
214 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
215 -- See #1641. This is pretty yucky, but I can't see a better way
216 -- to identify compiler-generated Ids, and at least this should
218 -- Only on exported things
219 | dopt Opt_AutoSccsOnExportedToplevs dflags
220 = AddSccs mod (\id -> idName id `elemNameSet` exports)
224 deSugarExpr :: HscEnv
225 -> Module -> GlobalRdrEnv -> TypeEnv
227 -> IO (Messages, Maybe CoreExpr)
228 -- Prints its own errors; returns Nothing if error occurred
230 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
231 let dflags = hsc_dflags hsc_env
232 showPass dflags "Desugar"
235 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
239 Nothing -> return (msgs, Nothing)
243 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
245 return (msgs, Just expr)
248 %************************************************************************
250 %* Add rules and export flags to binders
252 %************************************************************************
255 addExportFlagsAndRules
256 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
257 -> [(Id, t)] -> [(Id, t)]
258 addExportFlagsAndRules target exports keep_alive rules prs
261 add_one bndr = add_rules name (add_export name bndr)
265 ---------- Rules --------
266 -- See Note [Attach rules to local ids]
267 -- NB: the binder might have some existing rules,
268 -- arising from specialisation pragmas
270 | Just rules <- lookupNameEnv rule_base name
271 = bndr `addIdSpecialisations` rules
274 rule_base = extendRuleBaseList emptyRuleBase rules
276 ---------- Export flag --------
277 -- See Note [Adding export flags]
279 | dont_discard name = setIdExported bndr
282 dont_discard :: Name -> Bool
283 dont_discard name = is_exported name
284 || name `elemNameSet` keep_alive
286 -- In interactive mode, we don't want to discard any top-level
287 -- entities at all (eg. do not inline them away during
288 -- simplification), and retain them all in the TypeEnv so they are
289 -- available from the command line.
291 -- isExternalName separates the user-defined top-level names from those
292 -- introduced by the type checker.
293 is_exported :: Name -> Bool
294 is_exported | target == HscInterpreted = isExternalName
295 | otherwise = (`elemNameSet` exports)
299 Note [Adding export flags]
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~
301 Set the no-discard flag if either
302 a) the Id is exported
303 b) it's mentioned in the RHS of an orphan rule
304 c) it's in the keep-alive set
306 It means that the binding won't be discarded EVEN if the binding
307 ends up being trivial (v = w) -- the simplifier would usually just
308 substitute w for v throughout, but we don't apply the substitution to
309 the rules (maybe we should?), so this substitution would make the rule
312 You might wonder why exported Ids aren't already marked as such;
313 it's just because the type checker is rather busy already and
314 I didn't want to pass in yet another mapping.
316 Note [Attach rules to local ids]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318 Find the rules for locally-defined Ids; then we can attach them
319 to the binders in the top-level bindings
322 - It makes the rules easier to look up
323 - It means that transformation rules and specialisations for
324 locally defined Ids are handled uniformly
325 - It keeps alive things that are referred to only from a rule
326 (the occurrence analyser knows about rules attached to Ids)
327 - It makes sure that, when we apply a rule, the free vars
328 of the RHS are more likely to be in scope
329 - The imported rules are carried in the in-scope set
330 which is extended on each iteration by the new wave of
331 local binders; any rules which aren't on the binding will
335 %************************************************************************
337 %* Desugaring transformation rules
339 %************************************************************************
342 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
343 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
345 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
347 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
348 unsetOptM Opt_WarnIdentities $
349 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
351 ; rhs' <- dsLExpr rhs
353 -- Substitute the dict bindings eagerly,
354 -- and take the body apart into a (f args) form
355 ; case decomposeRuleLhs bndrs' lhs' of {
356 Left msg -> do { warnDs msg; return Nothing } ;
357 Right (final_bndrs, fn_id, args) -> do
359 { let is_local = isLocalId fn_id
360 -- NB: isLocalId is False of implicit Ids. This is good becuase
361 -- we don't want to attach rules to the bindings of implicit Ids,
362 -- because they don't show up in the bindings until just before code gen
363 fn_name = idName fn_id
364 final_rhs = simpleOptExpr rhs' -- De-crap it
365 rule = mkRule False {- Not auto -} is_local
366 name act fn_name final_bndrs args final_rhs
371 Note [Desugaring RULE left hand sides]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
373 For the LHS of a RULE we do *not* want to desugar
374 [x] to build (\cn. x `c` n)
375 We want to leave explicit lists simply as chains
376 of cons's. We can achieve that slightly indirectly by
377 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
379 That keeps the desugaring of list comprehensions simple too.
381 Nor do we want to warn of conversion identities on the LHS;
382 the rule is precisly to optimise them:
383 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
386 %************************************************************************
388 %* Desugaring vectorisation declarations
390 %************************************************************************
393 dsVect :: LVectDecl Id -> DsM CoreVect
394 dsVect (L loc (HsVect v rhs))
396 do { rhs' <- fmapMaybeM dsLExpr rhs
397 ; return $ Vect (unLoc v) rhs'
399 -- dsVect (L loc (HsVect v Nothing))
400 -- = return $ Vect v Nothing
401 -- dsVect (L loc (HsVect v (Just rhs)))
402 -- = putSrcSpanDs loc $
403 -- do { rhs' <- dsLExpr rhs
404 -- ; return $ Vect v (Just rhs')