- -- Lint result if necessary
- ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
-
- -- Dump output
- ; doIfSet (dopt Opt_D_dump_ds dflags)
- (printDump (ppr_ds_rules ds_rules))
-
- ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
- ; th_used <- readIORef th_var -- Whether TH is used
- ; let used_names = allUses dus `unionNameSets` dfun_uses
- pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
- | otherwise = imp_dep_pkgs imports
-
- dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
- -- M.hi-boot can be in the imp_dep_mods, but we must remove
- -- it before recording the modules on which this one depends!
- -- (We want to retain M.hi-boot in imp_dep_mods so that
- -- loadHiBootInterface can see if M's direct imports depend
- -- on M.hi-boot, and hence that we should do the hi-boot consistency
- -- check.)
-
- dir_imp_mods = imp_mods imports
-
- ; showPass dflags "Desugar 3"
-
- ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
-
- ; showPass dflags "Desugar 4"
-
- ; let
- -- Modules don't compare lexicographically usually,
- -- but we want them to do so here.
- le_mod :: Module -> Module -> Bool
- le_mod m1 m2 = moduleNameFS (moduleName m1)
- <= moduleNameFS (moduleName m2)
- le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool
- le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
-
- deps = Deps { dep_mods = sortLe le_dep_mod dep_mods,
- dep_pkgs = sortLe (<=) pkgs,
- dep_orphs = sortLe le_mod (imp_orphs imports) }
- -- sort to get into canonical order
-
- mod_guts = ModGuts {
- mg_module = mod,
- mg_boot = isHsBoot hsc_src,
- mg_exports = exports,
- mg_deps = deps,
- mg_usages = usages,
- mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
- mg_rdr_env = rdr_env,
- mg_fix_env = fix_env,
- mg_deprecs = deprecs,
- mg_types = type_env,
- mg_insts = insts,
- mg_rules = ds_rules,
- mg_binds = ds_binds,
- mg_foreign = ds_fords }
-
- ; return (warns, Just mod_guts)
- }}
+ -- Lint result if necessary, and print
+ ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
+ (vcat [ pprCoreBindings final_pgm
+ , pprRules rules_for_imps ])
+
+ ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
+ -- The simpleOptPgm gets rid of type
+ -- bindings plus any stupid dead code
+
+ ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+
+ ; let used_names = mkUsedNames tcg_env
+ ; deps <- mkDependencies tcg_env
+
+ ; let mod_guts = ModGuts {
+ mg_module = mod,
+ mg_boot = isHsBoot hsc_src,
+ mg_exports = exports,
+ mg_deps = deps,
+ mg_used_names = used_names,
+ mg_dir_imps = imp_mods imports,
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_warns = warns,
+ mg_anns = anns,
+ mg_types = type_env,
+ mg_insts = insts,
+ mg_fam_insts = fam_insts,
+ mg_inst_env = inst_env,
+ mg_fam_inst_env = fam_inst_env,
+ mg_rules = ds_rules_for_imps,
+ mg_binds = ds_binds,
+ mg_foreign = ds_fords,
+ mg_hpc_info = ds_hpc_info,
+ mg_modBreaks = modBreaks,
+ mg_vect_decls = ds_vects,
+ mg_vect_info = noVectInfo
+ }
+ ; return (msgs, Just mod_guts)
+ }}}
+
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
+ ; let (spec_binds, spec_rules) = unzip spec_prs
+ ; return (concatOL spec_binds, spec_rules) }
+
+combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
+-- Top-level bindings can include coercion bindings, but not via superclasses
+-- See Note [Top-level evidence]
+combineEvBinds [] val_prs
+ = [Rec val_prs]
+combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
+ | isId b = combineEvBinds bs ((b,r):val_prs)
+ | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
+ = combineEvBinds bs (prs ++ val_prs)
+combineEvBinds (CaseEvBind x _ _ : _) _
+ = pprPanic "topEvBindPairs" (ppr x)
+\end{code}