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
118 (binds_cvr,ds_hpc_info, modBreaks)
120 || target == HscInterpreted)
121 && (not (isHsBoot hsc_src))
122 then addCoverageTicksToBinds dflags mod mod_loc
123 (typeEnvTyCons type_env) binds
124 else return (binds, hpcInfo, emptyModBreaks)
125 initDs hsc_env mod rdr_env type_env $ do
126 do { ds_ev_binds <- dsEvBinds ev_binds
127 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
128 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
129 ; (ds_fords, foreign_prs) <- dsForeigns fords
130 ; ds_rules <- mapMaybeM dsRule rules
131 ; ds_vects <- mapM dsVect vects
132 ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
133 ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
134 ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
135 ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
136 ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
137 ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
138 ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
139 ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
140 ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
141 ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
142 ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
143 ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
144 ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
145 ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
146 ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
147 ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
148 ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
149 ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
150 ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
151 ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
152 ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
153 ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
155 | opt_Hpc = hpcInitCode mod ds_hpc_info
157 ; return ( ds_ev_binds
158 , foreign_prs `appOL` core_prs `appOL` spec_prs
159 , spec_rules ++ ds_rules, ds_vects
160 , ds_fords `appendStubC` hpc_init
161 , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc, hetmet_flatten, hetmet_flattened_id
169 , hetmet_pga_uncancell
170 , hetmet_pga_uncancelr
183 Nothing -> return (msgs, Nothing) ;
184 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
185 , hetmet_brak, hetmet_esc, hetmet_flatten, hetmet_flattened_id
193 , hetmet_pga_uncancell
194 , hetmet_pga_uncancelr
203 , hetmet_pga_curryr) -> do
205 { -- Add export flags to bindings
206 keep_alive <- readIORef keep_var
207 ; let (rules_for_locals, rules_for_imps)
208 = partition isLocalRule all_rules
209 final_prs = addExportFlagsAndRules target
210 export_set keep_alive rules_for_locals (fromOL all_prs)
212 final_pgm = combineEvBinds ds_ev_binds final_prs
213 -- Notice that we put the whole lot in a big Rec, even the foreign binds
214 -- When compiling PrelFloat, which defines data Float = F# Float#
215 -- we want F# to be in scope in the foreign marshalling code!
216 -- You might think it doesn't matter, but the simplifier brings all top-level
217 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
219 -- Lint result if necessary, and print
220 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
221 (vcat [ pprCoreBindings final_pgm
222 , pprRules rules_for_imps ])
224 ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
225 -- The simpleOptPgm gets rid of type
226 -- bindings plus any stupid dead code
228 ; ds_binds' <- if dopt Opt_F_coqpass dflags
229 then do { us <- mkSplitUniqSupply '~'
230 ; return (coqPassCoreToCore
258 ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
260 ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
262 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
264 ; let used_names = mkUsedNames tcg_env
265 ; deps <- mkDependencies tcg_env
267 ; let mod_guts = ModGuts {
269 mg_boot = isHsBoot hsc_src,
270 mg_exports = exports,
272 mg_used_names = used_names,
273 mg_dir_imps = imp_mods imports,
274 mg_rdr_env = rdr_env,
275 mg_fix_env = fix_env,
280 mg_fam_insts = fam_insts,
281 mg_inst_env = inst_env,
282 mg_fam_inst_env = fam_inst_env,
283 mg_rules = ds_rules_for_imps,
284 mg_binds = ds_binds',
285 mg_foreign = ds_fords,
286 mg_hpc_info = ds_hpc_info,
287 mg_modBreaks = modBreaks,
288 mg_vect_decls = ds_vects,
289 mg_vect_info = noVectInfo
291 ; return (msgs, Just mod_guts)
294 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
296 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
297 ; let (spec_binds, spec_rules) = unzip spec_prs
298 ; return (concatOL spec_binds, spec_rules) }
300 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
301 -- Top-level bindings can include coercion bindings, but not via superclasses
302 -- See Note [Top-level evidence]
303 combineEvBinds [] val_prs
305 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
306 | isId b = combineEvBinds bs ((b,r):val_prs)
307 | otherwise = NonRec b r : combineEvBinds bs val_prs
308 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
309 = combineEvBinds bs (prs ++ val_prs)
310 combineEvBinds (CaseEvBind x _ _ : _) _
311 = pprPanic "topEvBindPairs" (ppr x)
314 Note [Top-level evidence]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~
316 Top-level evidence bindings may be mutually recursive with the top-level value
317 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
318 because the occurrence analyser doesn't teke account of type/coercion variables
319 when computing dependencies.
321 So we pull out the type/coercion variables (which are in dependency order),
326 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
327 mkAutoScc dflags mod exports
328 | not opt_SccProfilingOn -- No profiling
330 -- Add auto-scc on all top-level things
331 | dopt Opt_AutoSccsOnAllToplevs dflags
332 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
333 -- See #1641. This is pretty yucky, but I can't see a better way
334 -- to identify compiler-generated Ids, and at least this should
336 -- Only on exported things
337 | dopt Opt_AutoSccsOnExportedToplevs dflags
338 = AddSccs mod (\id -> idName id `elemNameSet` exports)
342 deSugarExpr :: HscEnv
343 -> Module -> GlobalRdrEnv -> TypeEnv
345 -> IO (Messages, Maybe CoreExpr)
346 -- Prints its own errors; returns Nothing if error occurred
348 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
349 let dflags = hsc_dflags hsc_env
350 showPass dflags "Desugar"
353 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
357 Nothing -> return (msgs, Nothing)
361 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
363 return (msgs, Just expr)
366 %************************************************************************
368 %* Add rules and export flags to binders
370 %************************************************************************
373 addExportFlagsAndRules
374 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
375 -> [(Id, t)] -> [(Id, t)]
376 addExportFlagsAndRules target exports keep_alive rules prs
379 add_one bndr = add_rules name (add_export name bndr)
383 ---------- Rules --------
384 -- See Note [Attach rules to local ids]
385 -- NB: the binder might have some existing rules,
386 -- arising from specialisation pragmas
388 | Just rules <- lookupNameEnv rule_base name
389 = bndr `addIdSpecialisations` rules
392 rule_base = extendRuleBaseList emptyRuleBase rules
394 ---------- Export flag --------
395 -- See Note [Adding export flags]
397 | dont_discard name = setIdExported bndr
400 dont_discard :: Name -> Bool
401 dont_discard name = is_exported name
402 || name `elemNameSet` keep_alive
404 -- In interactive mode, we don't want to discard any top-level
405 -- entities at all (eg. do not inline them away during
406 -- simplification), and retain them all in the TypeEnv so they are
407 -- available from the command line.
409 -- isExternalName separates the user-defined top-level names from those
410 -- introduced by the type checker.
411 is_exported :: Name -> Bool
412 is_exported | target == HscInterpreted = isExternalName
413 | otherwise = (`elemNameSet` exports)
417 Note [Adding export flags]
418 ~~~~~~~~~~~~~~~~~~~~~~~~~~
419 Set the no-discard flag if either
420 a) the Id is exported
421 b) it's mentioned in the RHS of an orphan rule
422 c) it's in the keep-alive set
424 It means that the binding won't be discarded EVEN if the binding
425 ends up being trivial (v = w) -- the simplifier would usually just
426 substitute w for v throughout, but we don't apply the substitution to
427 the rules (maybe we should?), so this substitution would make the rule
430 You might wonder why exported Ids aren't already marked as such;
431 it's just because the type checker is rather busy already and
432 I didn't want to pass in yet another mapping.
434 Note [Attach rules to local ids]
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436 Find the rules for locally-defined Ids; then we can attach them
437 to the binders in the top-level bindings
440 - It makes the rules easier to look up
441 - It means that transformation rules and specialisations for
442 locally defined Ids are handled uniformly
443 - It keeps alive things that are referred to only from a rule
444 (the occurrence analyser knows about rules attached to Ids)
445 - It makes sure that, when we apply a rule, the free vars
446 of the RHS are more likely to be in scope
447 - The imported rules are carried in the in-scope set
448 which is extended on each iteration by the new wave of
449 local binders; any rules which aren't on the binding will
453 %************************************************************************
455 %* Desugaring transformation rules
457 %************************************************************************
460 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
461 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
463 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
465 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
466 unsetOptM Opt_WarnIdentities $
467 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
469 ; rhs' <- dsLExpr rhs
471 -- Substitute the dict bindings eagerly,
472 -- and take the body apart into a (f args) form
473 ; case decomposeRuleLhs bndrs' lhs' of {
474 Left msg -> do { warnDs msg; return Nothing } ;
475 Right (final_bndrs, fn_id, args) -> do
477 { let is_local = isLocalId fn_id
478 -- NB: isLocalId is False of implicit Ids. This is good becuase
479 -- we don't want to attach rules to the bindings of implicit Ids,
480 -- because they don't show up in the bindings until just before code gen
481 fn_name = idName fn_id
482 final_rhs = simpleOptExpr rhs' -- De-crap it
483 rule = mkRule False {- Not auto -} is_local
484 name act fn_name final_bndrs args final_rhs
489 Note [Desugaring RULE left hand sides]
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 For the LHS of a RULE we do *not* want to desugar
492 [x] to build (\cn. x `c` n)
493 We want to leave explicit lists simply as chains
494 of cons's. We can achieve that slightly indirectly by
495 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
497 That keeps the desugaring of list comprehensions simple too.
499 Nor do we want to warn of conversion identities on the LHS;
500 the rule is precisly to optimise them:
501 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
504 %************************************************************************
506 %* Desugaring vectorisation declarations
508 %************************************************************************
511 dsVect :: LVectDecl Id -> DsM CoreVect
512 dsVect (L loc (HsVect v rhs))
514 do { rhs' <- fmapMaybeM dsLExpr rhs
515 ; return $ Vect (unLoc v) rhs'
517 -- dsVect (L loc (HsVect v Nothing))
518 -- = return $ Vect v Nothing
519 -- dsVect (L loc (HsVect v (Just rhs)))
520 -- = putSrcSpanDs loc $
521 -- do { rhs' <- dsLExpr rhs
522 -- ; return $ Vect v (Just rhs')