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 CoqPass ( coqPassCoreToString, coqPassCoreToCore )
31 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
32 -- depends on DsExpr.hi-boot.
38 import CoreMonad ( endPass, CoreToDo(..), CoreM, runCoreM, lookupOrigCoreM )
57 %************************************************************************
59 %* The main function: deSugar
61 %************************************************************************
65 -- | Main entry point to the desugarer.
66 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
67 -- Can modify PCS by faulting in more declarations
71 tcg_env@(TcGblEnv { tcg_mod = mod,
73 tcg_type_env = type_env,
74 tcg_imports = imports,
75 tcg_exports = exports,
77 tcg_rdr_env = rdr_env,
78 tcg_fix_env = fix_env,
79 tcg_inst_env = inst_env,
80 tcg_fam_inst_env = fam_inst_env,
84 tcg_imp_specs = imp_specs,
85 tcg_ev_binds = ev_binds,
90 tcg_fam_insts = fam_insts,
91 tcg_hpc = other_hpc_info })
93 = do { let dflags = hsc_dflags hsc_env
94 ; showPass dflags "Desugar"
96 -- Desugar the program
97 ; let export_set = availsToNameSet exports
98 ; let auto_scc = mkAutoScc dflags mod export_set
99 ; let target = hscTarget dflags
100 ; let hpcInfo = emptyHpcInfo other_hpc_info
104 return (emptyMessages,
105 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
107 (binds_cvr,ds_hpc_info, modBreaks)
109 || target == HscInterpreted)
110 && (not (isHsBoot hsc_src))
111 then addCoverageTicksToBinds dflags mod mod_loc
112 (typeEnvTyCons type_env) binds
113 else return (binds, hpcInfo, emptyModBreaks)
115 initDs hsc_env mod rdr_env type_env $ do
116 do { ds_ev_binds <- dsEvBinds ev_binds
117 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
118 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
119 ; (ds_fords, foreign_prs) <- dsForeigns fords
120 ; ds_rules <- mapMaybeM dsRule rules
121 ; ds_vects <- mapM dsVect vects
123 | opt_Hpc = hpcInitCode mod ds_hpc_info
125 ; return ( ds_ev_binds
126 , foreign_prs `appOL` core_prs `appOL` spec_prs
127 , spec_rules ++ ds_rules, ds_vects
128 , ds_fords `appendStubC` hpc_init
129 , ds_hpc_info, modBreaks)
133 Nothing -> return (msgs, Nothing) ;
134 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
136 { -- Add export flags to bindings
137 keep_alive <- readIORef keep_var
138 ; let (rules_for_locals, rules_for_imps)
139 = partition isLocalRule all_rules
140 final_prs = addExportFlagsAndRules target
141 export_set keep_alive rules_for_locals (fromOL all_prs)
143 final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
144 in if dopt Opt_F_simpleopt_before_flatten dflags
146 else simplifyBinds comb
147 -- Notice that we put the whole lot in a big Rec, even the foreign binds
148 -- When compiling PrelFloat, which defines data Float = F# Float#
149 -- we want F# to be in scope in the foreign marshalling code!
150 -- You might think it doesn't matter, but the simplifier brings all top-level
151 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
153 ; (final_pgm1, rules_for_imps1, ds_vects1) <- if dopt Opt_F_simpleopt_before_flatten dflags
154 then simpleOptPgm dflags final_pgm rules_for_imps vects0
155 else return (final_pgm, rules_for_imps, vects0)
157 ; ds_binds1 <- if dopt Opt_F_coqpass dflags
158 then do { us1 <- mkSplitUniqSupply '*' -- hack
159 ; us2 <- mkSplitUniqSupply '~' -- hack
160 ; let do_flatten = dopt Opt_F_flatten dflags
161 ; let do_skolemize = dopt Opt_F_skolemize dflags
162 ; let mon = runCoreM hsc_env (mkRuleBase rules_for_imps1) us1 mod
163 $ coqPassCoreToCore do_flatten do_skolemize dsLookupVar dsLookupTyc us2 final_pgm1
165 dsLookupVar :: String -> String -> CoreM Var
166 dsLookupVar modname varname
167 = do { name <- lookupOrigCoreM
168 (mkBaseModule (fsLit modname))
169 (mkOccNameFS varName (fsLit varname))
172 dsLookupTyc :: String -> String -> CoreM TyCon
173 dsLookupTyc modname tycname
174 = do { name <- lookupOrigCoreM
175 (mkBaseModule (fsLit modname))
176 (mkOccNameFS tcName (fsLit tycname))
182 else return final_pgm
184 ; (ds_binds2, ds_rules_for_imps2, ds_vects2) <- if dopt Opt_F_simpleopt_before_flatten dflags
185 then return (ds_binds1, rules_for_imps1, ds_vects1)
186 else simpleOptPgm dflags ds_binds1 rules_for_imps1 ds_vects1
187 -- The simpleOptPgm gets rid of type
188 -- bindings plus any stupid dead code
190 ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds1
192 ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds1)
194 ; (ds_binds3, ds_rules_for_imps3, ds_vects3)
195 <- simpleOptPgm dflags ds_binds2 ds_rules_for_imps2 ds_vects2
196 -- The simpleOptPgm gets rid of type
197 -- bindings plus any stupid dead code
199 ; endPass dflags CoreDesugar ds_binds3 ds_rules_for_imps3
201 ; let used_names = mkUsedNames tcg_env
202 ; deps <- mkDependencies tcg_env
204 ; let mod_guts = ModGuts {
206 mg_boot = isHsBoot hsc_src,
207 mg_exports = exports,
209 mg_used_names = used_names,
210 mg_dir_imps = imp_mods imports,
211 mg_rdr_env = rdr_env,
212 mg_fix_env = fix_env,
217 mg_fam_insts = fam_insts,
218 mg_inst_env = inst_env,
219 mg_fam_inst_env = fam_inst_env,
220 mg_rules = ds_rules_for_imps3,
221 mg_binds = ds_binds3,
222 mg_foreign = ds_fords,
223 mg_hpc_info = ds_hpc_info,
224 mg_modBreaks = modBreaks,
225 mg_vect_decls = ds_vects2,
226 mg_vect_info = noVectInfo
228 ; return (msgs, Just mod_guts)
231 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
233 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
234 ; let (spec_binds, spec_rules) = unzip spec_prs
235 ; return (concatOL spec_binds, spec_rules) }
237 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
238 -- Top-level bindings can include coercion bindings, but not via superclasses
239 -- See Note [Top-level evidence]
240 combineEvBinds [] val_prs
242 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
243 | isId b = combineEvBinds bs ((b,r):val_prs)
244 | otherwise = NonRec b r : combineEvBinds bs val_prs
245 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
246 = combineEvBinds bs (prs ++ val_prs)
247 combineEvBinds (CaseEvBind x _ _ : _) _
248 = pprPanic "topEvBindPairs" (ppr x)
251 Note [Top-level evidence]
252 ~~~~~~~~~~~~~~~~~~~~~~~~~
253 Top-level evidence bindings may be mutually recursive with the top-level value
254 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
255 because the occurrence analyser doesn't teke account of type/coercion variables
256 when computing dependencies.
258 So we pull out the type/coercion variables (which are in dependency order),
263 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
264 mkAutoScc dflags mod exports
265 | not opt_SccProfilingOn -- No profiling
267 -- Add auto-scc on all top-level things
268 | dopt Opt_AutoSccsOnAllToplevs dflags
269 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
270 -- See #1641. This is pretty yucky, but I can't see a better way
271 -- to identify compiler-generated Ids, and at least this should
273 -- Only on exported things
274 | dopt Opt_AutoSccsOnExportedToplevs dflags
275 = AddSccs mod (\id -> idName id `elemNameSet` exports)
279 deSugarExpr :: HscEnv
280 -> Module -> GlobalRdrEnv -> TypeEnv
282 -> IO (Messages, Maybe CoreExpr)
283 -- Prints its own errors; returns Nothing if error occurred
285 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
286 let dflags = hsc_dflags hsc_env
287 showPass dflags "Desugar"
290 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
294 Nothing -> return (msgs, Nothing)
298 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
300 return (msgs, Just expr)
303 %************************************************************************
305 %* Add rules and export flags to binders
307 %************************************************************************
310 addExportFlagsAndRules
311 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
312 -> [(Id, t)] -> [(Id, t)]
313 addExportFlagsAndRules target exports keep_alive rules prs
316 add_one bndr = add_rules name (add_export name bndr)
320 ---------- Rules --------
321 -- See Note [Attach rules to local ids]
322 -- NB: the binder might have some existing rules,
323 -- arising from specialisation pragmas
325 | Just rules <- lookupNameEnv rule_base name
326 = bndr `addIdSpecialisations` rules
329 rule_base = extendRuleBaseList emptyRuleBase rules
331 ---------- Export flag --------
332 -- See Note [Adding export flags]
334 | dont_discard name = setIdExported bndr
337 dont_discard :: Name -> Bool
338 dont_discard name = is_exported name
339 || name `elemNameSet` keep_alive
341 -- In interactive mode, we don't want to discard any top-level
342 -- entities at all (eg. do not inline them away during
343 -- simplification), and retain them all in the TypeEnv so they are
344 -- available from the command line.
346 -- isExternalName separates the user-defined top-level names from those
347 -- introduced by the type checker.
348 is_exported :: Name -> Bool
349 is_exported | target == HscInterpreted = isExternalName
350 | otherwise = (`elemNameSet` exports)
354 Note [Adding export flags]
355 ~~~~~~~~~~~~~~~~~~~~~~~~~~
356 Set the no-discard flag if either
357 a) the Id is exported
358 b) it's mentioned in the RHS of an orphan rule
359 c) it's in the keep-alive set
361 It means that the binding won't be discarded EVEN if the binding
362 ends up being trivial (v = w) -- the simplifier would usually just
363 substitute w for v throughout, but we don't apply the substitution to
364 the rules (maybe we should?), so this substitution would make the rule
367 You might wonder why exported Ids aren't already marked as such;
368 it's just because the type checker is rather busy already and
369 I didn't want to pass in yet another mapping.
371 Note [Attach rules to local ids]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
373 Find the rules for locally-defined Ids; then we can attach them
374 to the binders in the top-level bindings
377 - It makes the rules easier to look up
378 - It means that transformation rules and specialisations for
379 locally defined Ids are handled uniformly
380 - It keeps alive things that are referred to only from a rule
381 (the occurrence analyser knows about rules attached to Ids)
382 - It makes sure that, when we apply a rule, the free vars
383 of the RHS are more likely to be in scope
384 - The imported rules are carried in the in-scope set
385 which is extended on each iteration by the new wave of
386 local binders; any rules which aren't on the binding will
390 %************************************************************************
392 %* Desugaring transformation rules
394 %************************************************************************
397 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
398 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
400 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
402 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
403 unsetOptM Opt_WarnIdentities $
404 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
406 ; rhs' <- dsLExpr rhs
408 -- Substitute the dict bindings eagerly,
409 -- and take the body apart into a (f args) form
410 ; case decomposeRuleLhs bndrs' lhs' of {
411 Left msg -> do { warnDs msg; return Nothing } ;
412 Right (final_bndrs, fn_id, args) -> do
414 { let is_local = isLocalId fn_id
415 -- NB: isLocalId is False of implicit Ids. This is good becuase
416 -- we don't want to attach rules to the bindings of implicit Ids,
417 -- because they don't show up in the bindings until just before code gen
418 fn_name = idName fn_id
419 final_rhs = simpleOptExpr rhs' -- De-crap it
420 rule = mkRule False {- Not auto -} is_local
421 name act fn_name final_bndrs args final_rhs
426 Note [Desugaring RULE left hand sides]
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
428 For the LHS of a RULE we do *not* want to desugar
429 [x] to build (\cn. x `c` n)
430 We want to leave explicit lists simply as chains
431 of cons's. We can achieve that slightly indirectly by
432 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
434 That keeps the desugaring of list comprehensions simple too.
438 Nor do we want to warn of conversion identities on the LHS;
439 the rule is precisly to optimise them:
440 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
443 %************************************************************************
445 %* Desugaring vectorisation declarations
447 %************************************************************************
450 dsVect :: LVectDecl Id -> DsM CoreVect
451 dsVect (L loc (HsVect (L _ v) rhs))
453 do { rhs' <- fmapMaybeM dsLExpr rhs
454 ; return $ Vect v rhs'
456 dsVect (L _loc (HsNoVect (L _ v)))
464 -- Simplification routines run before the flattener. We can't use
465 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
466 -- let-binding groups.
468 simplify :: Expr CoreBndr -> Expr CoreBndr
469 simplify (Var v) = Var v
470 simplify (App e1 e2) = App (simplify e1) (simplify e2)
471 simplify (Lit lit) = Lit lit
472 simplify (Note note e) = Note note (simplify e)
473 simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
475 else Cast (simplify e) co
476 simplify (Lam v e) = Lam v (simplify e)
477 simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
478 simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
479 simplify (Type t) = Type t
480 simplify (Coercion co) = Coercion co
482 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
483 simplifyBind (NonRec b e) = [NonRec b (simplify e)]
484 simplifyBind (Rec []) = []
485 simplifyBind (Rec (rbs@((b,e):rbs'))) =
486 if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
487 then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
488 else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
490 simplifyBinds = concatMap simplifyBind