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
108 ; return ( ds_ev_binds
109 , foreign_prs `appOL` core_prs `appOL` spec_prs
110 , spec_rules ++ ds_rules, ds_vects
111 , ds_fords, ds_hpc_info, modBreaks) }
114 Nothing -> return (msgs, Nothing) ;
115 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
117 { -- Add export flags to bindings
118 keep_alive <- readIORef keep_var
119 ; let (rules_for_locals, rules_for_imps)
120 = partition isLocalRule all_rules
121 final_prs = addExportFlagsAndRules target
122 export_set keep_alive rules_for_locals (fromOL all_prs)
124 final_pgm = combineEvBinds ds_ev_binds final_prs
125 -- Notice that we put the whole lot in a big Rec, even the foreign binds
126 -- When compiling PrelFloat, which defines data Float = F# Float#
127 -- we want F# to be in scope in the foreign marshalling code!
128 -- You might think it doesn't matter, but the simplifier brings all top-level
129 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
131 -- Lint result if necessary, and print
132 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
133 (vcat [ pprCoreBindings final_pgm
134 , pprRules rules_for_imps ])
136 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
137 -- The simpleOptPgm gets rid of type
138 -- bindings plus any stupid dead code
140 ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
142 ; let used_names = mkUsedNames tcg_env
143 ; deps <- mkDependencies tcg_env
145 ; let mod_guts = ModGuts {
147 mg_boot = isHsBoot hsc_src,
148 mg_exports = exports,
150 mg_used_names = used_names,
151 mg_dir_imps = imp_mods imports,
152 mg_rdr_env = rdr_env,
153 mg_fix_env = fix_env,
158 mg_fam_insts = fam_insts,
159 mg_inst_env = inst_env,
160 mg_fam_inst_env = fam_inst_env,
161 mg_rules = ds_rules_for_imps,
163 mg_foreign = ds_fords,
164 mg_hpc_info = ds_hpc_info,
165 mg_modBreaks = modBreaks,
166 mg_vect_decls = ds_vects,
167 mg_vect_info = noVectInfo
169 ; return (msgs, Just mod_guts)
172 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
174 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
175 ; let (spec_binds, spec_rules) = unzip spec_prs
176 ; return (concatOL spec_binds, spec_rules) }
178 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
179 -- Top-level bindings can include coercion bindings, but not via superclasses
180 -- See Note [Top-level evidence]
181 combineEvBinds [] val_prs
183 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
184 | isId b = combineEvBinds bs ((b,r):val_prs)
185 | otherwise = NonRec b r : combineEvBinds bs val_prs
186 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
187 = combineEvBinds bs (prs ++ val_prs)
188 combineEvBinds (CaseEvBind x _ _ : _) _
189 = pprPanic "topEvBindPairs" (ppr x)
192 Note [Top-level evidence]
193 ~~~~~~~~~~~~~~~~~~~~~~~~~
194 Top-level evidence bindings may be mutually recursive with the top-level value
195 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
196 because the occurrence analyser doesn't teke account of type/coercion variables
197 when computing dependencies.
199 So we pull out the type/coercion variables (which are in dependency order),
204 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
205 mkAutoScc dflags mod exports
206 | not opt_SccProfilingOn -- No profiling
208 -- Add auto-scc on all top-level things
209 | dopt Opt_AutoSccsOnAllToplevs dflags
210 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
211 -- See #1641. This is pretty yucky, but I can't see a better way
212 -- to identify compiler-generated Ids, and at least this should
214 -- Only on exported things
215 | dopt Opt_AutoSccsOnExportedToplevs dflags
216 = AddSccs mod (\id -> idName id `elemNameSet` exports)
220 deSugarExpr :: HscEnv
221 -> Module -> GlobalRdrEnv -> TypeEnv
223 -> IO (Messages, Maybe CoreExpr)
224 -- Prints its own errors; returns Nothing if error occurred
226 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
227 let dflags = hsc_dflags hsc_env
228 showPass dflags "Desugar"
231 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
235 Nothing -> return (msgs, Nothing)
239 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
241 return (msgs, Just expr)
244 %************************************************************************
246 %* Add rules and export flags to binders
248 %************************************************************************
251 addExportFlagsAndRules
252 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
253 -> [(Id, t)] -> [(Id, t)]
254 addExportFlagsAndRules target exports keep_alive rules prs
257 add_one bndr = add_rules name (add_export name bndr)
261 ---------- Rules --------
262 -- See Note [Attach rules to local ids]
263 -- NB: the binder might have some existing rules,
264 -- arising from specialisation pragmas
266 | Just rules <- lookupNameEnv rule_base name
267 = bndr `addIdSpecialisations` rules
270 rule_base = extendRuleBaseList emptyRuleBase rules
272 ---------- Export flag --------
273 -- See Note [Adding export flags]
275 | dont_discard name = setIdExported bndr
278 dont_discard :: Name -> Bool
279 dont_discard name = is_exported name
280 || name `elemNameSet` keep_alive
282 -- In interactive mode, we don't want to discard any top-level
283 -- entities at all (eg. do not inline them away during
284 -- simplification), and retain them all in the TypeEnv so they are
285 -- available from the command line.
287 -- isExternalName separates the user-defined top-level names from those
288 -- introduced by the type checker.
289 is_exported :: Name -> Bool
290 is_exported | target == HscInterpreted = isExternalName
291 | otherwise = (`elemNameSet` exports)
295 Note [Adding export flags]
296 ~~~~~~~~~~~~~~~~~~~~~~~~~~
297 Set the no-discard flag if either
298 a) the Id is exported
299 b) it's mentioned in the RHS of an orphan rule
300 c) it's in the keep-alive set
302 It means that the binding won't be discarded EVEN if the binding
303 ends up being trivial (v = w) -- the simplifier would usually just
304 substitute w for v throughout, but we don't apply the substitution to
305 the rules (maybe we should?), so this substitution would make the rule
308 You might wonder why exported Ids aren't already marked as such;
309 it's just because the type checker is rather busy already and
310 I didn't want to pass in yet another mapping.
312 Note [Attach rules to local ids]
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314 Find the rules for locally-defined Ids; then we can attach them
315 to the binders in the top-level bindings
318 - It makes the rules easier to look up
319 - It means that transformation rules and specialisations for
320 locally defined Ids are handled uniformly
321 - It keeps alive things that are referred to only from a rule
322 (the occurrence analyser knows about rules attached to Ids)
323 - It makes sure that, when we apply a rule, the free vars
324 of the RHS are more likely to be in scope
325 - The imported rules are carried in the in-scope set
326 which is extended on each iteration by the new wave of
327 local binders; any rules which aren't on the binding will
331 %************************************************************************
333 %* Desugaring transformation rules
335 %************************************************************************
338 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
339 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
341 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
343 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
344 unsetOptM Opt_WarnIdentities $
345 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
347 ; rhs' <- dsLExpr rhs
349 -- Substitute the dict bindings eagerly,
350 -- and take the body apart into a (f args) form
351 ; case decomposeRuleLhs bndrs' lhs' of {
352 Left msg -> do { warnDs msg; return Nothing } ;
353 Right (final_bndrs, fn_id, args) -> do
355 { let is_local = isLocalId fn_id
356 -- NB: isLocalId is False of implicit Ids. This is good becuase
357 -- we don't want to attach rules to the bindings of implicit Ids,
358 -- because they don't show up in the bindings until just before code gen
359 fn_name = idName fn_id
360 final_rhs = simpleOptExpr rhs' -- De-crap it
361 rule = mkRule False {- Not auto -} is_local
362 name act fn_name final_bndrs args final_rhs
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.
377 Nor do we want to warn of conversion identities on the LHS;
378 the rule is precisly to optimise them:
379 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
382 %************************************************************************
384 %* Desugaring vectorisation declarations
386 %************************************************************************
389 dsVect :: LVectDecl Id -> DsM CoreVect
390 dsVect (L loc (HsVect v rhs))
392 do { rhs' <- fmapMaybeM dsLExpr rhs
393 ; return $ Vect (unLoc v) rhs'
395 -- dsVect (L loc (HsVect v Nothing))
396 -- = return $ Vect v Nothing
397 -- dsVect (L loc (HsVect v (Just rhs)))
398 -- = putSrcSpanDs loc $
399 -- do { rhs' <- dsLExpr rhs
400 -- ; return $ Vect v (Just rhs')