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
25 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
26 -- depends on DsExpr.hi-boot.
31 import CoreMonad ( endPass )
42 %************************************************************************
44 %* The main function: deSugar
46 %************************************************************************
49 -- | Main entry point to the desugarer.
50 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
51 -- Can modify PCS by faulting in more declarations
55 tcg_env@(TcGblEnv { tcg_mod = mod,
57 tcg_type_env = type_env,
58 tcg_imports = imports,
59 tcg_exports = exports,
61 tcg_rdr_env = rdr_env,
62 tcg_fix_env = fix_env,
63 tcg_inst_env = inst_env,
64 tcg_fam_inst_env = fam_inst_env,
71 tcg_fam_insts = fam_insts,
72 tcg_hpc = other_hpc_info })
74 = do { let dflags = hsc_dflags hsc_env
75 ; showPass dflags "Desugar"
77 -- Desugar the program
78 ; let export_set = availsToNameSet exports
79 ; let auto_scc = mkAutoScc dflags mod export_set
80 ; let target = hscTarget dflags
81 ; let hpcInfo = emptyHpcInfo other_hpc_info
85 return (emptyMessages,
86 Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
88 (binds_cvr,ds_hpc_info, modBreaks)
90 || target == HscInterpreted)
91 && (not (isHsBoot hsc_src))
92 then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
93 else return (binds, hpcInfo, emptyModBreaks)
94 initDs hsc_env mod rdr_env type_env $ do
95 core_prs <- dsTopLHsBinds auto_scc binds_cvr
96 (ds_fords, foreign_prs) <- dsForeigns fords
97 let all_prs = foreign_prs ++ core_prs
98 ds_rules <- mapM dsRule rules
99 return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
102 Nothing -> return (msgs, Nothing) ;
103 Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
105 { -- Add export flags to bindings
106 keep_alive <- readIORef keep_var
107 ; let final_prs = addExportFlags target export_set
109 ds_binds = [Rec final_prs]
110 -- Notice that we put the whole lot in a big Rec, even the foreign binds
111 -- When compiling PrelFloat, which defines data Float = F# Float#
112 -- we want F# to be in scope in the foreign marshalling code!
113 -- You might think it doesn't matter, but the simplifier brings all top-level
114 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
116 -- Lint result if necessary
117 ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules
120 ; doIfSet (dopt Opt_D_dump_ds dflags)
121 (printDump (ppr_ds_rules ds_rules))
123 ; used_names <- mkUsedNames tcg_env
124 ; deps <- mkDependencies tcg_env
126 ; let mod_guts = ModGuts {
128 mg_boot = isHsBoot hsc_src,
129 mg_exports = exports,
131 mg_used_names = used_names,
132 mg_dir_imps = imp_mods imports,
133 mg_rdr_env = rdr_env,
134 mg_fix_env = fix_env,
139 mg_fam_insts = fam_insts,
140 mg_inst_env = inst_env,
141 mg_fam_inst_env = fam_inst_env,
144 mg_foreign = ds_fords,
145 mg_hpc_info = ds_hpc_info,
146 mg_modBreaks = modBreaks,
147 mg_vect_info = noVectInfo
149 ; return (msgs, Just mod_guts)
152 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
153 mkAutoScc dflags mod exports
154 | not opt_SccProfilingOn -- No profiling
156 -- Add auto-scc on all top-level things
157 | dopt Opt_AutoSccsOnAllToplevs dflags
158 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
159 -- See #1641. This is pretty yucky, but I can't see a better way
160 -- to identify compiler-generated Ids, and at least this should
162 -- Only on exported things
163 | dopt Opt_AutoSccsOnExportedToplevs dflags
164 = AddSccs mod (\id -> idName id `elemNameSet` exports)
168 deSugarExpr :: HscEnv
169 -> Module -> GlobalRdrEnv -> TypeEnv
171 -> IO (Messages, Maybe CoreExpr)
172 -- Prints its own errors; returns Nothing if error occurred
174 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
175 let dflags = hsc_dflags hsc_env
176 showPass dflags "Desugar"
179 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
183 Nothing -> return (msgs, Nothing)
187 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
189 return (msgs, Just expr)
192 -- Set the no-discard flag if either
193 -- a) the Id is exported
194 -- b) it's mentioned in the RHS of an orphan rule
195 -- c) it's in the keep-alive set
197 -- It means that the binding won't be discarded EVEN if the binding
198 -- ends up being trivial (v = w) -- the simplifier would usually just
199 -- substitute w for v throughout, but we don't apply the substitution to
200 -- the rules (maybe we should?), so this substitution would make the rule
203 -- You might wonder why exported Ids aren't already marked as such;
204 -- it's just because the type checker is rather busy already and
205 -- I didn't want to pass in yet another mapping.
207 addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)]
209 addExportFlags target exports keep_alive prs
210 = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
213 | dont_discard bndr = setIdExported bndr
216 dont_discard bndr = is_exported name
217 || name `elemNameSet` keep_alive
221 -- In interactive mode, we don't want to discard any top-level
222 -- entities at all (eg. do not inline them away during
223 -- simplification), and retain them all in the TypeEnv so they are
224 -- available from the command line.
226 -- isExternalName separates the user-defined top-level names from those
227 -- introduced by the type checker.
228 is_exported :: Name -> Bool
229 is_exported | target == HscInterpreted = isExternalName
230 | otherwise = (`elemNameSet` exports)
232 ppr_ds_rules :: [CoreRule] -> SDoc
233 ppr_ds_rules [] = empty
235 = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$
241 %************************************************************************
243 %* Desugaring transformation rules
245 %************************************************************************
248 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
249 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
251 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
253 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
254 dsLExpr lhs -- Note [Desugaring RULE lhss]
256 ; rhs' <- dsLExpr rhs
258 -- Substitute the dict bindings eagerly,
259 -- and take the body apart into a (f args) form
260 ; case decomposeRuleLhs (mkLams bndrs' lhs') of {
261 Nothing -> do { warnDs msg; return Nothing } ;
262 Just (bndrs, fn_id, args) -> do
264 { let local_rule = isLocalId fn_id
265 -- NB: isLocalId is False of implicit Ids. This is good becuase
266 -- we don't want to attach rules to the bindings of implicit Ids,
267 -- because they don't show up in the bindings until just before code gen
268 fn_name = idName fn_id
269 rule = mkRule local_rule name act fn_name bndrs args rhs'
273 msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
277 Note [Desugaring RULE left hand sides]
278 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
279 For the LHS of a RULE we do *not* want to desugar
280 [x] to build (\cn. x `c` n)
281 We want to leave explicit lists simply as chains
282 of cons's. We can achieve that slightly indirectly by
283 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
285 That keeps the desugaring of list comprehensions simple too.