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
11 #include "HsVersions.h"
28 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
29 -- depends on DsExpr.hi-boot.
51 %************************************************************************
53 %* The main function: deSugar
55 %************************************************************************
58 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts)
59 -- Can modify PCS by faulting in more declarations
63 tcg_env@(TcGblEnv { tcg_mod = mod,
65 tcg_type_env = type_env,
66 tcg_imports = imports,
67 tcg_exports = exports,
69 tcg_inst_uses = dfun_uses_var,
72 tcg_rdr_env = rdr_env,
73 tcg_fix_env = fix_env,
74 tcg_inst_env = inst_env,
75 tcg_fam_inst_env = fam_inst_env,
76 tcg_deprecs = deprecs,
81 tcg_fam_insts = fam_insts,
82 tcg_hpc = other_hpc_info })
84 = do { let dflags = hsc_dflags hsc_env
85 ; showPass dflags "Desugar"
87 -- Desugar the program
88 ; let export_set = availsToNameSet exports
89 ; let auto_scc = mkAutoScc mod export_set
90 ; let target = hscTarget dflags
91 ; let hpcInfo = emptyHpcInfo other_hpc_info
92 ; mb_res <- case target of
93 HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
94 _ -> do (binds_cvr,ds_hpc_info, modBreaks)
96 || target == HscInterpreted)
97 && (not (isHsBoot hsc_src))
98 then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
99 else return (binds, hpcInfo, emptyModBreaks)
100 initDs hsc_env mod rdr_env type_env $ do
101 { core_prs <- dsTopLHsBinds auto_scc binds_cvr
102 ; (ds_fords, foreign_prs) <- dsForeigns fords
103 ; let all_prs = foreign_prs ++ core_prs
104 local_bndrs = mkVarSet (map fst all_prs)
105 ; ds_rules <- mappM (dsRule mod local_bndrs) rules
106 ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
109 Nothing -> return Nothing ;
110 Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
112 { -- Add export flags to bindings
113 keep_alive <- readIORef keep_var
114 ; let final_prs = addExportFlags target export_set
115 keep_alive all_prs ds_rules
116 ds_binds = [Rec final_prs]
117 -- Notice that we put the whole lot in a big Rec, even the foreign binds
118 -- When compiling PrelFloat, which defines data Float = F# Float#
119 -- we want F# to be in scope in the foreign marshalling code!
120 -- You might think it doesn't matter, but the simplifier brings all top-level
121 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
123 -- Lint result if necessary
124 ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
127 ; doIfSet (dopt Opt_D_dump_ds dflags)
128 (printDump (ppr_ds_rules ds_rules))
130 ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
131 ; th_used <- readIORef th_var -- Whether TH is used
132 ; let used_names = allUses dus `unionNameSets` dfun_uses
133 pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
134 | otherwise = imp_dep_pkgs imports
136 dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
137 -- M.hi-boot can be in the imp_dep_mods, but we must remove
138 -- it before recording the modules on which this one depends!
139 -- (We want to retain M.hi-boot in imp_dep_mods so that
140 -- loadHiBootInterface can see if M's direct imports depend
141 -- on M.hi-boot, and hence that we should do the hi-boot consistency
144 dir_imp_mods = imp_mods imports
146 ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
149 -- Modules don't compare lexicographically usually,
150 -- but we want them to do so here.
151 le_mod :: Module -> Module -> Bool
152 le_mod m1 m2 = moduleNameFS (moduleName m1)
153 <= moduleNameFS (moduleName m2)
154 le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool
155 le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
157 deps = Deps { dep_mods = sortLe le_dep_mod dep_mods,
158 dep_pkgs = sortLe (<=) pkgs,
159 dep_orphs = sortLe le_mod (imp_orphs imports),
160 dep_finsts = sortLe le_mod (imp_finsts imports) }
161 -- sort to get into canonical order
165 mg_boot = isHsBoot hsc_src,
166 mg_exports = exports,
169 mg_dir_imps = [m | (m, _) <- moduleEnvElts dir_imp_mods],
170 mg_rdr_env = rdr_env,
171 mg_fix_env = fix_env,
172 mg_deprecs = deprecs,
175 mg_fam_insts = fam_insts,
176 mg_inst_env = inst_env,
177 mg_fam_inst_env = fam_inst_env,
180 mg_foreign = ds_fords,
181 mg_hpc_info = ds_hpc_info,
182 mg_modBreaks = modBreaks,
183 mg_vect_info = noVectInfo
185 ; return (Just mod_guts)
188 mkAutoScc :: Module -> NameSet -> AutoScc
189 mkAutoScc mod exports
190 | not opt_SccProfilingOn -- No profiling
192 | opt_AutoSccsOnAllToplevs -- Add auto-scc on all top-level things
193 = AddSccs mod (\id -> True)
194 | opt_AutoSccsOnExportedToplevs -- Only on exported things
195 = AddSccs mod (\id -> idName id `elemNameSet` exports)
200 deSugarExpr :: HscEnv
201 -> Module -> GlobalRdrEnv -> TypeEnv
203 -> IO (Maybe CoreExpr)
204 -- Prints its own errors; returns Nothing if error occurred
206 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
207 = do { let dflags = hsc_dflags hsc_env
208 ; showPass dflags "Desugar"
211 ; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
214 ; case mb_core_expr of {
215 Nothing -> return Nothing ;
219 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
221 ; return (Just expr) } } }
224 -- Set the no-discard flag if either
225 -- a) the Id is exported
226 -- b) it's mentioned in the RHS of an orphan rule
227 -- c) it's in the keep-alive set
229 -- It means that the binding won't be discarded EVEN if the binding
230 -- ends up being trivial (v = w) -- the simplifier would usually just
231 -- substitute w for v throughout, but we don't apply the substitution to
232 -- the rules (maybe we should?), so this substitution would make the rule
235 -- You might wonder why exported Ids aren't already marked as such;
236 -- it's just because the type checker is rather busy already and
237 -- I didn't want to pass in yet another mapping.
239 addExportFlags target exports keep_alive prs rules
240 = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
243 | dont_discard bndr = setIdExported bndr
246 orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
248 not (isLocalRule rule) ]
249 -- A non-local rule keeps alive the free vars of its right-hand side.
250 -- (A "non-local" is one whose head function is not locally defined.)
251 -- Local rules are (later, after gentle simplification)
252 -- attached to the Id, and that keeps the rhs free vars alive.
254 dont_discard bndr = is_exported name
255 || name `elemNameSet` keep_alive
256 || bndr `elemVarSet` orph_rhs_fvs
260 -- In interactive mode, we don't want to discard any top-level
261 -- entities at all (eg. do not inline them away during
262 -- simplification), and retain them all in the TypeEnv so they are
263 -- available from the command line.
265 -- isExternalName separates the user-defined top-level names from those
266 -- introduced by the type checker.
267 is_exported :: Name -> Bool
268 is_exported | target == HscInterpreted = isExternalName
269 | otherwise = (`elemNameSet` exports)
271 ppr_ds_rules [] = empty
273 = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
279 %************************************************************************
281 %* Desugaring transformation rules
283 %************************************************************************
286 dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
287 dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
289 do { let bndrs = [var | RuleBndr (L _ var) <- vars]
290 ; lhs' <- dsLExpr lhs
291 ; rhs' <- dsLExpr rhs
293 ; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
294 Nothing -> do { warnDs msg; return Nothing } ;
295 Just (fn_id, args) -> do
297 -- Substitute the dict bindings eagerly,
298 -- and take the body apart into a (f args) form
299 { let local_rule = isLocalId fn_id
300 -- NB: isLocalId is False of implicit Ids. This is good becuase
301 -- we don't want to attach rules to the bindings of implicit Ids,
302 -- because they don't show up in the bindings until just before code gen
303 fn_name = idName fn_id
305 rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
306 ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
307 ru_rough = roughTopNames args,
308 ru_local = local_rule }
312 msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))