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
114 | opt_Hpc = hpcInitCode mod ds_hpc_info
116 ; return ( ds_ev_binds
117 , foreign_prs `appOL` core_prs `appOL` spec_prs
118 , spec_rules ++ ds_rules, ds_vects
119 , ds_fords `appendStubC` hpc_init
120 , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) }
123 Nothing -> return (msgs, Nothing) ;
124 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do
126 { -- Add export flags to bindings
127 keep_alive <- readIORef keep_var
128 ; let (rules_for_locals, rules_for_imps)
129 = partition isLocalRule all_rules
130 final_prs = addExportFlagsAndRules target
131 export_set keep_alive rules_for_locals (fromOL all_prs)
133 final_pgm = combineEvBinds ds_ev_binds final_prs
134 -- Notice that we put the whole lot in a big Rec, even the foreign binds
135 -- When compiling PrelFloat, which defines data Float = F# Float#
136 -- we want F# to be in scope in the foreign marshalling code!
137 -- You might think it doesn't matter, but the simplifier brings all top-level
138 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
140 -- Lint result if necessary, and print
141 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
142 (vcat [ pprCoreBindings final_pgm
143 , pprRules rules_for_imps ])
145 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
146 -- The simpleOptPgm gets rid of type
147 -- bindings plus any stupid dead code
149 ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds
151 ; ds_binds' <- if dopt Opt_F_coqpass dflags
152 then do { us <- mkSplitUniqSupply '~'
153 ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds
157 ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
159 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
161 ; let used_names = mkUsedNames tcg_env
162 ; deps <- mkDependencies tcg_env
164 ; let mod_guts = ModGuts {
166 mg_boot = isHsBoot hsc_src,
167 mg_exports = exports,
169 mg_used_names = used_names,
170 mg_dir_imps = imp_mods imports,
171 mg_rdr_env = rdr_env,
172 mg_fix_env = fix_env,
177 mg_fam_insts = fam_insts,
178 mg_inst_env = inst_env,
179 mg_fam_inst_env = fam_inst_env,
180 mg_rules = ds_rules_for_imps,
181 mg_binds = ds_binds',
182 mg_foreign = ds_fords,
183 mg_hpc_info = ds_hpc_info,
184 mg_modBreaks = modBreaks,
185 mg_vect_decls = ds_vects,
186 mg_vect_info = noVectInfo
188 ; return (msgs, Just mod_guts)
191 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
193 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
194 ; let (spec_binds, spec_rules) = unzip spec_prs
195 ; return (concatOL spec_binds, spec_rules) }
197 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
198 -- Top-level bindings can include coercion bindings, but not via superclasses
199 -- See Note [Top-level evidence]
200 combineEvBinds [] val_prs
202 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
203 | isId b = combineEvBinds bs ((b,r):val_prs)
204 | otherwise = NonRec b r : combineEvBinds bs val_prs
205 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
206 = combineEvBinds bs (prs ++ val_prs)
207 combineEvBinds (CaseEvBind x _ _ : _) _
208 = pprPanic "topEvBindPairs" (ppr x)
211 Note [Top-level evidence]
212 ~~~~~~~~~~~~~~~~~~~~~~~~~
213 Top-level evidence bindings may be mutually recursive with the top-level value
214 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
215 because the occurrence analyser doesn't teke account of type/coercion variables
216 when computing dependencies.
218 So we pull out the type/coercion variables (which are in dependency order),
223 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
224 mkAutoScc dflags mod exports
225 | not opt_SccProfilingOn -- No profiling
227 -- Add auto-scc on all top-level things
228 | dopt Opt_AutoSccsOnAllToplevs dflags
229 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
230 -- See #1641. This is pretty yucky, but I can't see a better way
231 -- to identify compiler-generated Ids, and at least this should
233 -- Only on exported things
234 | dopt Opt_AutoSccsOnExportedToplevs dflags
235 = AddSccs mod (\id -> idName id `elemNameSet` exports)
239 deSugarExpr :: HscEnv
240 -> Module -> GlobalRdrEnv -> TypeEnv
242 -> IO (Messages, Maybe CoreExpr)
243 -- Prints its own errors; returns Nothing if error occurred
245 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
246 let dflags = hsc_dflags hsc_env
247 showPass dflags "Desugar"
250 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
254 Nothing -> return (msgs, Nothing)
258 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
260 return (msgs, Just expr)
263 %************************************************************************
265 %* Add rules and export flags to binders
267 %************************************************************************
270 addExportFlagsAndRules
271 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
272 -> [(Id, t)] -> [(Id, t)]
273 addExportFlagsAndRules target exports keep_alive rules prs
276 add_one bndr = add_rules name (add_export name bndr)
280 ---------- Rules --------
281 -- See Note [Attach rules to local ids]
282 -- NB: the binder might have some existing rules,
283 -- arising from specialisation pragmas
285 | Just rules <- lookupNameEnv rule_base name
286 = bndr `addIdSpecialisations` rules
289 rule_base = extendRuleBaseList emptyRuleBase rules
291 ---------- Export flag --------
292 -- See Note [Adding export flags]
294 | dont_discard name = setIdExported bndr
297 dont_discard :: Name -> Bool
298 dont_discard name = is_exported name
299 || name `elemNameSet` keep_alive
301 -- In interactive mode, we don't want to discard any top-level
302 -- entities at all (eg. do not inline them away during
303 -- simplification), and retain them all in the TypeEnv so they are
304 -- available from the command line.
306 -- isExternalName separates the user-defined top-level names from those
307 -- introduced by the type checker.
308 is_exported :: Name -> Bool
309 is_exported | target == HscInterpreted = isExternalName
310 | otherwise = (`elemNameSet` exports)
314 Note [Adding export flags]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~
316 Set the no-discard flag if either
317 a) the Id is exported
318 b) it's mentioned in the RHS of an orphan rule
319 c) it's in the keep-alive set
321 It means that the binding won't be discarded EVEN if the binding
322 ends up being trivial (v = w) -- the simplifier would usually just
323 substitute w for v throughout, but we don't apply the substitution to
324 the rules (maybe we should?), so this substitution would make the rule
327 You might wonder why exported Ids aren't already marked as such;
328 it's just because the type checker is rather busy already and
329 I didn't want to pass in yet another mapping.
331 Note [Attach rules to local ids]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 Find the rules for locally-defined Ids; then we can attach them
334 to the binders in the top-level bindings
337 - It makes the rules easier to look up
338 - It means that transformation rules and specialisations for
339 locally defined Ids are handled uniformly
340 - It keeps alive things that are referred to only from a rule
341 (the occurrence analyser knows about rules attached to Ids)
342 - It makes sure that, when we apply a rule, the free vars
343 of the RHS are more likely to be in scope
344 - The imported rules are carried in the in-scope set
345 which is extended on each iteration by the new wave of
346 local binders; any rules which aren't on the binding will
350 %************************************************************************
352 %* Desugaring transformation rules
354 %************************************************************************
357 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
358 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
360 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
362 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
363 unsetOptM Opt_WarnIdentities $
364 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
366 ; rhs' <- dsLExpr rhs
368 -- Substitute the dict bindings eagerly,
369 -- and take the body apart into a (f args) form
370 ; case decomposeRuleLhs bndrs' lhs' of {
371 Left msg -> do { warnDs msg; return Nothing } ;
372 Right (final_bndrs, fn_id, args) -> do
374 { let is_local = isLocalId fn_id
375 -- NB: isLocalId is False of implicit Ids. This is good becuase
376 -- we don't want to attach rules to the bindings of implicit Ids,
377 -- because they don't show up in the bindings until just before code gen
378 fn_name = idName fn_id
379 final_rhs = simpleOptExpr rhs' -- De-crap it
380 rule = mkRule False {- Not auto -} is_local
381 name act fn_name final_bndrs args final_rhs
386 Note [Desugaring RULE left hand sides]
387 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
388 For the LHS of a RULE we do *not* want to desugar
389 [x] to build (\cn. x `c` n)
390 We want to leave explicit lists simply as chains
391 of cons's. We can achieve that slightly indirectly by
392 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
394 That keeps the desugaring of list comprehensions simple too.
396 Nor do we want to warn of conversion identities on the LHS;
397 the rule is precisly to optimise them:
398 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
401 %************************************************************************
403 %* Desugaring vectorisation declarations
405 %************************************************************************
408 dsVect :: LVectDecl Id -> DsM CoreVect
409 dsVect (L loc (HsVect v rhs))
411 do { rhs' <- fmapMaybeM dsLExpr rhs
412 ; return $ Vect (unLoc v) rhs'
414 -- dsVect (L loc (HsVect v Nothing))
415 -- = return $ Vect v Nothing
416 -- dsVect (L loc (HsVect v (Just rhs)))
417 -- = putSrcSpanDs loc $
418 -- do { rhs' <- dsLExpr rhs
419 -- ; return $ Vect v (Just rhs')