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
21 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
27 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
28 -- depends on DsExpr.hi-boot.
34 import CoreMonad ( endPass, CoreToDo(..) )
48 %************************************************************************
50 %* The main function: deSugar
52 %************************************************************************
55 -- | Main entry point to the desugarer.
56 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
57 -- Can modify PCS by faulting in more declarations
61 tcg_env@(TcGblEnv { tcg_mod = mod,
63 tcg_type_env = type_env,
64 tcg_imports = imports,
65 tcg_exports = exports,
67 tcg_rdr_env = rdr_env,
68 tcg_fix_env = fix_env,
69 tcg_inst_env = inst_env,
70 tcg_fam_inst_env = fam_inst_env,
74 tcg_imp_specs = imp_specs,
75 tcg_ev_binds = ev_binds,
80 tcg_fam_insts = fam_insts,
81 tcg_hpc = other_hpc_info })
83 = do { let dflags = hsc_dflags hsc_env
84 ; showPass dflags "Desugar"
86 -- Desugar the program
87 ; let export_set = availsToNameSet exports
88 ; let auto_scc = mkAutoScc dflags mod export_set
89 ; let target = hscTarget dflags
90 ; let hpcInfo = emptyHpcInfo other_hpc_info
94 return (emptyMessages,
95 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined))
97 (binds_cvr,ds_hpc_info, modBreaks)
99 || target == HscInterpreted)
100 && (not (isHsBoot hsc_src))
101 then addCoverageTicksToBinds dflags mod mod_loc
102 (typeEnvTyCons type_env) binds
103 else return (binds, hpcInfo, emptyModBreaks)
104 initDs hsc_env mod rdr_env type_env $ do
105 do { ds_ev_binds <- dsEvBinds ev_binds
106 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
107 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
108 ; (ds_fords, foreign_prs) <- dsForeigns fords
109 ; ds_rules <- mapMaybeM dsRule rules
110 ; ds_vects <- mapM dsVect vects
111 ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
112 ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
113 ; return ( ds_ev_binds
114 , foreign_prs `appOL` core_prs `appOL` spec_prs
115 , spec_rules ++ ds_rules, ds_vects
116 , ds_fords, ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) }
119 Nothing -> return (msgs, Nothing) ;
120 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do
122 { -- Add export flags to bindings
123 keep_alive <- readIORef keep_var
124 ; let (rules_for_locals, rules_for_imps)
125 = partition isLocalRule all_rules
126 final_prs = addExportFlagsAndRules target
127 export_set keep_alive rules_for_locals (fromOL all_prs)
129 final_pgm = combineEvBinds ds_ev_binds final_prs
130 -- Notice that we put the whole lot in a big Rec, even the foreign binds
131 -- When compiling PrelFloat, which defines data Float = F# Float#
132 -- we want F# to be in scope in the foreign marshalling code!
133 -- You might think it doesn't matter, but the simplifier brings all top-level
134 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
136 -- Lint result if necessary, and print
137 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
138 (vcat [ pprCoreBindings final_pgm
139 , pprRules rules_for_imps ])
141 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
142 -- The simpleOptPgm gets rid of type
143 -- bindings plus any stupid dead code
145 ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds
147 ; ds_binds' <- if dopt Opt_F_coqpass dflags
148 then do { us <- mkSplitUniqSupply '~'
149 ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds
153 ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
155 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
157 ; let used_names = mkUsedNames tcg_env
158 ; deps <- mkDependencies tcg_env
160 ; let mod_guts = ModGuts {
162 mg_boot = isHsBoot hsc_src,
163 mg_exports = exports,
165 mg_used_names = used_names,
166 mg_dir_imps = imp_mods imports,
167 mg_rdr_env = rdr_env,
168 mg_fix_env = fix_env,
173 mg_fam_insts = fam_insts,
174 mg_inst_env = inst_env,
175 mg_fam_inst_env = fam_inst_env,
176 mg_rules = ds_rules_for_imps,
177 mg_binds = ds_binds',
178 mg_foreign = ds_fords,
179 mg_hpc_info = ds_hpc_info,
180 mg_modBreaks = modBreaks,
181 mg_vect_decls = ds_vects,
182 mg_vect_info = noVectInfo
184 ; return (msgs, Just mod_guts)
187 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
189 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
190 ; let (spec_binds, spec_rules) = unzip spec_prs
191 ; return (concatOL spec_binds, spec_rules) }
193 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
194 -- Top-level bindings can include coercion bindings, but not via superclasses
195 -- See Note [Top-level evidence]
196 combineEvBinds [] val_prs
198 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
199 | isId b = combineEvBinds bs ((b,r):val_prs)
200 | otherwise = NonRec b r : combineEvBinds bs val_prs
201 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
202 = combineEvBinds bs (prs ++ val_prs)
203 combineEvBinds (CaseEvBind x _ _ : _) _
204 = pprPanic "topEvBindPairs" (ppr x)
207 Note [Top-level evidence]
208 ~~~~~~~~~~~~~~~~~~~~~~~~~
209 Top-level evidence bindings may be mutually recursive with the top-level value
210 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
211 because the occurrence analyser doesn't teke account of type/coercion variables
212 when computing dependencies.
214 So we pull out the type/coercion variables (which are in dependency order),
219 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
220 mkAutoScc dflags mod exports
221 | not opt_SccProfilingOn -- No profiling
223 -- Add auto-scc on all top-level things
224 | dopt Opt_AutoSccsOnAllToplevs dflags
225 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
226 -- See #1641. This is pretty yucky, but I can't see a better way
227 -- to identify compiler-generated Ids, and at least this should
229 -- Only on exported things
230 | dopt Opt_AutoSccsOnExportedToplevs dflags
231 = AddSccs mod (\id -> idName id `elemNameSet` exports)
235 deSugarExpr :: HscEnv
236 -> Module -> GlobalRdrEnv -> TypeEnv
238 -> IO (Messages, Maybe CoreExpr)
239 -- Prints its own errors; returns Nothing if error occurred
241 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
242 let dflags = hsc_dflags hsc_env
243 showPass dflags "Desugar"
246 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
250 Nothing -> return (msgs, Nothing)
254 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
256 return (msgs, Just expr)
259 %************************************************************************
261 %* Add rules and export flags to binders
263 %************************************************************************
266 addExportFlagsAndRules
267 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
268 -> [(Id, t)] -> [(Id, t)]
269 addExportFlagsAndRules target exports keep_alive rules prs
272 add_one bndr = add_rules name (add_export name bndr)
276 ---------- Rules --------
277 -- See Note [Attach rules to local ids]
278 -- NB: the binder might have some existing rules,
279 -- arising from specialisation pragmas
281 | Just rules <- lookupNameEnv rule_base name
282 = bndr `addIdSpecialisations` rules
285 rule_base = extendRuleBaseList emptyRuleBase rules
287 ---------- Export flag --------
288 -- See Note [Adding export flags]
290 | dont_discard name = setIdExported bndr
293 dont_discard :: Name -> Bool
294 dont_discard name = is_exported name
295 || name `elemNameSet` keep_alive
297 -- In interactive mode, we don't want to discard any top-level
298 -- entities at all (eg. do not inline them away during
299 -- simplification), and retain them all in the TypeEnv so they are
300 -- available from the command line.
302 -- isExternalName separates the user-defined top-level names from those
303 -- introduced by the type checker.
304 is_exported :: Name -> Bool
305 is_exported | target == HscInterpreted = isExternalName
306 | otherwise = (`elemNameSet` exports)
310 Note [Adding export flags]
311 ~~~~~~~~~~~~~~~~~~~~~~~~~~
312 Set the no-discard flag if either
313 a) the Id is exported
314 b) it's mentioned in the RHS of an orphan rule
315 c) it's in the keep-alive set
317 It means that the binding won't be discarded EVEN if the binding
318 ends up being trivial (v = w) -- the simplifier would usually just
319 substitute w for v throughout, but we don't apply the substitution to
320 the rules (maybe we should?), so this substitution would make the rule
323 You might wonder why exported Ids aren't already marked as such;
324 it's just because the type checker is rather busy already and
325 I didn't want to pass in yet another mapping.
327 Note [Attach rules to local ids]
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
329 Find the rules for locally-defined Ids; then we can attach them
330 to the binders in the top-level bindings
333 - It makes the rules easier to look up
334 - It means that transformation rules and specialisations for
335 locally defined Ids are handled uniformly
336 - It keeps alive things that are referred to only from a rule
337 (the occurrence analyser knows about rules attached to Ids)
338 - It makes sure that, when we apply a rule, the free vars
339 of the RHS are more likely to be in scope
340 - The imported rules are carried in the in-scope set
341 which is extended on each iteration by the new wave of
342 local binders; any rules which aren't on the binding will
346 %************************************************************************
348 %* Desugaring transformation rules
350 %************************************************************************
353 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
354 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
356 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
358 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
359 unsetOptM Opt_WarnIdentities $
360 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
362 ; rhs' <- dsLExpr rhs
364 -- Substitute the dict bindings eagerly,
365 -- and take the body apart into a (f args) form
366 ; case decomposeRuleLhs bndrs' lhs' of {
367 Left msg -> do { warnDs msg; return Nothing } ;
368 Right (final_bndrs, fn_id, args) -> do
370 { let is_local = isLocalId fn_id
371 -- NB: isLocalId is False of implicit Ids. This is good becuase
372 -- we don't want to attach rules to the bindings of implicit Ids,
373 -- because they don't show up in the bindings until just before code gen
374 fn_name = idName fn_id
375 final_rhs = simpleOptExpr rhs' -- De-crap it
376 rule = mkRule False {- Not auto -} is_local
377 name act fn_name final_bndrs args final_rhs
382 Note [Desugaring RULE left hand sides]
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 For the LHS of a RULE we do *not* want to desugar
385 [x] to build (\cn. x `c` n)
386 We want to leave explicit lists simply as chains
387 of cons's. We can achieve that slightly indirectly by
388 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
390 That keeps the desugaring of list comprehensions simple too.
392 Nor do we want to warn of conversion identities on the LHS;
393 the rule is precisly to optimise them:
394 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
397 %************************************************************************
399 %* Desugaring vectorisation declarations
401 %************************************************************************
404 dsVect :: LVectDecl Id -> DsM CoreVect
405 dsVect (L loc (HsVect v rhs))
407 do { rhs' <- fmapMaybeM dsLExpr rhs
408 ; return $ Vect (unLoc v) rhs'
410 -- dsVect (L loc (HsVect v Nothing))
411 -- = return $ Vect v Nothing
412 -- dsVect (L loc (HsVect v (Just rhs)))
413 -- = putSrcSpanDs loc $
414 -- do { rhs' <- dsLExpr rhs
415 -- ; return $ Vect v (Just rhs')