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(..) )
52 %************************************************************************
54 %* The main function: deSugar
56 %************************************************************************
60 -- | Main entry point to the desugarer.
61 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
62 -- Can modify PCS by faulting in more declarations
66 tcg_env@(TcGblEnv { tcg_mod = mod,
68 tcg_type_env = type_env,
69 tcg_imports = imports,
70 tcg_exports = exports,
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,
79 tcg_imp_specs = imp_specs,
80 tcg_ev_binds = ev_binds,
85 tcg_fam_insts = fam_insts,
86 tcg_hpc = other_hpc_info })
88 = do { let dflags = hsc_dflags hsc_env
89 ; showPass dflags "Desugar"
91 -- Desugar the program
92 ; let export_set = availsToNameSet exports
93 ; let auto_scc = mkAutoScc dflags mod export_set
94 ; let target = hscTarget dflags
95 ; let hpcInfo = emptyHpcInfo other_hpc_info
99 return (emptyMessages,
100 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
127 (binds_cvr,ds_hpc_info, modBreaks)
129 || target == HscInterpreted)
130 && (not (isHsBoot hsc_src))
131 then addCoverageTicksToBinds dflags mod mod_loc
132 (typeEnvTyCons type_env) binds
133 else return (binds, hpcInfo, emptyModBreaks)
134 initDs hsc_env mod rdr_env type_env $ do
135 do { ds_ev_binds <- dsEvBinds ev_binds
136 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
137 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
138 ; (ds_fords, foreign_prs) <- dsForeigns fords
139 ; ds_rules <- mapMaybeM dsRule rules
140 ; ds_vects <- mapM dsVect vects
141 ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
142 ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
143 ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
144 ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
145 ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
146 ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
147 ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
148 ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
149 ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
150 ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
151 ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
152 ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
153 ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
154 ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
155 ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
156 ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
157 ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
158 ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
159 ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
160 ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
161 ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
162 ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
163 ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
164 ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
165 ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
166 ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
168 | opt_Hpc = hpcInitCode mod ds_hpc_info
170 ; return ( ds_ev_binds
171 , foreign_prs `appOL` core_prs `appOL` spec_prs
172 , spec_rules ++ ds_rules, ds_vects
173 , ds_fords `appendStubC` hpc_init
174 , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
177 , hetmet_flattened_id
179 , hetmet_PGArrow_unit
180 , hetmet_PGArrow_tensor
181 , hetmet_PGArrow_exponent
188 , hetmet_pga_uncancell
189 , hetmet_pga_uncancelr
202 Nothing -> return (msgs, Nothing) ;
203 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
204 , hetmet_brak, hetmet_esc
207 , hetmet_flattened_id
209 , hetmet_PGArrow_unit
210 , hetmet_PGArrow_tensor
211 , hetmet_PGArrow_exponent
218 , hetmet_pga_uncancell
219 , hetmet_pga_uncancelr
228 , hetmet_pga_curryr) -> do
230 { -- Add export flags to bindings
231 keep_alive <- readIORef keep_var
232 ; let (rules_for_locals, rules_for_imps)
233 = partition isLocalRule all_rules
234 final_prs = addExportFlagsAndRules target
235 export_set keep_alive rules_for_locals (fromOL all_prs)
237 final_pgm = simplifyBinds $ combineEvBinds ds_ev_binds final_prs
238 -- Notice that we put the whole lot in a big Rec, even the foreign binds
239 -- When compiling PrelFloat, which defines data Float = F# Float#
240 -- we want F# to be in scope in the foreign marshalling code!
241 -- You might think it doesn't matter, but the simplifier brings all top-level
242 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
244 -- Lint result if necessary, and print
245 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
246 (vcat [ pprCoreBindings final_pgm
247 , pprRules rules_for_imps ])
249 ; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
250 then simpleOptPgm dflags final_pgm rules_for_imps
251 else return (final_pgm, rules_for_imps)
253 ; ds_binds <- if dopt Opt_F_coqpass dflags
254 then do { us <- mkSplitUniqSupply '~'
255 ; let do_flatten = dopt Opt_F_flatten dflags
256 ; let do_skolemize = dopt Opt_F_skolemize dflags
257 ; return (coqPassCoreToCore
269 hetmet_PGArrow_tensor
270 hetmet_PGArrow_exponent
289 else return final_pgm
291 ; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags
292 then return (ds_binds, rules_for_imps')
293 else simpleOptPgm dflags ds_binds rules_for_imps'
294 -- The simpleOptPgm gets rid of type
295 -- bindings plus any stupid dead code
297 ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
299 ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
301 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
303 ; let used_names = mkUsedNames tcg_env
304 ; deps <- mkDependencies tcg_env
306 ; let mod_guts = ModGuts {
308 mg_boot = isHsBoot hsc_src,
309 mg_exports = exports,
311 mg_used_names = used_names,
312 mg_dir_imps = imp_mods imports,
313 mg_rdr_env = rdr_env,
314 mg_fix_env = fix_env,
319 mg_fam_insts = fam_insts,
320 mg_inst_env = inst_env,
321 mg_fam_inst_env = fam_inst_env,
322 mg_rules = ds_rules_for_imps,
323 mg_binds = ds_binds',
324 mg_foreign = ds_fords,
325 mg_hpc_info = ds_hpc_info,
326 mg_modBreaks = modBreaks,
327 mg_vect_decls = ds_vects,
328 mg_vect_info = noVectInfo
330 ; return (msgs, Just mod_guts)
333 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
335 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
336 ; let (spec_binds, spec_rules) = unzip spec_prs
337 ; return (concatOL spec_binds, spec_rules) }
339 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
340 -- Top-level bindings can include coercion bindings, but not via superclasses
341 -- See Note [Top-level evidence]
342 combineEvBinds [] val_prs
344 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
345 | isId b = combineEvBinds bs ((b,r):val_prs)
346 | otherwise = NonRec b r : combineEvBinds bs val_prs
347 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
348 = combineEvBinds bs (prs ++ val_prs)
349 combineEvBinds (CaseEvBind x _ _ : _) _
350 = pprPanic "topEvBindPairs" (ppr x)
353 Note [Top-level evidence]
354 ~~~~~~~~~~~~~~~~~~~~~~~~~
355 Top-level evidence bindings may be mutually recursive with the top-level value
356 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
357 because the occurrence analyser doesn't teke account of type/coercion variables
358 when computing dependencies.
360 So we pull out the type/coercion variables (which are in dependency order),
365 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
366 mkAutoScc dflags mod exports
367 | not opt_SccProfilingOn -- No profiling
369 -- Add auto-scc on all top-level things
370 | dopt Opt_AutoSccsOnAllToplevs dflags
371 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
372 -- See #1641. This is pretty yucky, but I can't see a better way
373 -- to identify compiler-generated Ids, and at least this should
375 -- Only on exported things
376 | dopt Opt_AutoSccsOnExportedToplevs dflags
377 = AddSccs mod (\id -> idName id `elemNameSet` exports)
381 deSugarExpr :: HscEnv
382 -> Module -> GlobalRdrEnv -> TypeEnv
384 -> IO (Messages, Maybe CoreExpr)
385 -- Prints its own errors; returns Nothing if error occurred
387 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
388 let dflags = hsc_dflags hsc_env
389 showPass dflags "Desugar"
392 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
396 Nothing -> return (msgs, Nothing)
400 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
402 return (msgs, Just expr)
405 %************************************************************************
407 %* Add rules and export flags to binders
409 %************************************************************************
412 addExportFlagsAndRules
413 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
414 -> [(Id, t)] -> [(Id, t)]
415 addExportFlagsAndRules target exports keep_alive rules prs
418 add_one bndr = add_rules name (add_export name bndr)
422 ---------- Rules --------
423 -- See Note [Attach rules to local ids]
424 -- NB: the binder might have some existing rules,
425 -- arising from specialisation pragmas
427 | Just rules <- lookupNameEnv rule_base name
428 = bndr `addIdSpecialisations` rules
431 rule_base = extendRuleBaseList emptyRuleBase rules
433 ---------- Export flag --------
434 -- See Note [Adding export flags]
436 | dont_discard name = setIdExported bndr
439 dont_discard :: Name -> Bool
440 dont_discard name = is_exported name
441 || name `elemNameSet` keep_alive
443 -- In interactive mode, we don't want to discard any top-level
444 -- entities at all (eg. do not inline them away during
445 -- simplification), and retain them all in the TypeEnv so they are
446 -- available from the command line.
448 -- isExternalName separates the user-defined top-level names from those
449 -- introduced by the type checker.
450 is_exported :: Name -> Bool
451 is_exported | target == HscInterpreted = isExternalName
452 | otherwise = (`elemNameSet` exports)
456 Note [Adding export flags]
457 ~~~~~~~~~~~~~~~~~~~~~~~~~~
458 Set the no-discard flag if either
459 a) the Id is exported
460 b) it's mentioned in the RHS of an orphan rule
461 c) it's in the keep-alive set
463 It means that the binding won't be discarded EVEN if the binding
464 ends up being trivial (v = w) -- the simplifier would usually just
465 substitute w for v throughout, but we don't apply the substitution to
466 the rules (maybe we should?), so this substitution would make the rule
469 You might wonder why exported Ids aren't already marked as such;
470 it's just because the type checker is rather busy already and
471 I didn't want to pass in yet another mapping.
473 Note [Attach rules to local ids]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 Find the rules for locally-defined Ids; then we can attach them
476 to the binders in the top-level bindings
479 - It makes the rules easier to look up
480 - It means that transformation rules and specialisations for
481 locally defined Ids are handled uniformly
482 - It keeps alive things that are referred to only from a rule
483 (the occurrence analyser knows about rules attached to Ids)
484 - It makes sure that, when we apply a rule, the free vars
485 of the RHS are more likely to be in scope
486 - The imported rules are carried in the in-scope set
487 which is extended on each iteration by the new wave of
488 local binders; any rules which aren't on the binding will
492 %************************************************************************
494 %* Desugaring transformation rules
496 %************************************************************************
499 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
500 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
502 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
504 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
505 unsetOptM Opt_WarnIdentities $
506 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
508 ; rhs' <- dsLExpr rhs
510 -- Substitute the dict bindings eagerly,
511 -- and take the body apart into a (f args) form
512 ; case decomposeRuleLhs bndrs' lhs' of {
513 Left msg -> do { warnDs msg; return Nothing } ;
514 Right (final_bndrs, fn_id, args) -> do
516 { let is_local = isLocalId fn_id
517 -- NB: isLocalId is False of implicit Ids. This is good becuase
518 -- we don't want to attach rules to the bindings of implicit Ids,
519 -- because they don't show up in the bindings until just before code gen
520 fn_name = idName fn_id
521 final_rhs = simpleOptExpr rhs' -- De-crap it
522 rule = mkRule False {- Not auto -} is_local
523 name act fn_name final_bndrs args final_rhs
528 Note [Desugaring RULE left hand sides]
529 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
530 For the LHS of a RULE we do *not* want to desugar
531 [x] to build (\cn. x `c` n)
532 We want to leave explicit lists simply as chains
533 of cons's. We can achieve that slightly indirectly by
534 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
536 That keeps the desugaring of list comprehensions simple too.
540 Nor do we want to warn of conversion identities on the LHS;
541 the rule is precisly to optimise them:
542 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
545 %************************************************************************
547 %* Desugaring vectorisation declarations
549 %************************************************************************
552 dsVect :: LVectDecl Id -> DsM CoreVect
553 dsVect (L loc (HsVect v rhs))
555 do { rhs' <- fmapMaybeM dsLExpr rhs
556 ; return $ Vect (unLoc v) rhs'
558 -- dsVect (L loc (HsVect v Nothing))
559 -- = return $ Vect v Nothing
560 -- dsVect (L loc (HsVect v (Just rhs)))
561 -- = putSrcSpanDs loc $
562 -- do { rhs' <- dsLExpr rhs
563 -- ; return $ Vect v (Just rhs')
571 -- Simplification routines run before the flattener. We can't use
572 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
573 -- let-binding groups.
575 simplify :: Expr CoreBndr -> Expr CoreBndr
576 simplify (Var v) = Var v
577 simplify (App e1 e2) = App (simplify e1) (simplify e2)
578 simplify (Lit lit) = Lit lit
579 simplify (Note note e) = Note note (simplify e)
580 simplify (Cast e co) = if tcEqType (fst $ coercionKind co) (snd $ coercionKind co)
582 else Cast (simplify e) co
583 simplify (Lam v e) = Lam v (simplify e)
584 simplify (Type t) = Type t
585 simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
586 simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
588 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
589 simplifyBind (NonRec b e) = [NonRec b (simplify e)]
590 simplifyBind (Rec []) = []
591 simplifyBind (Rec (rbs@((b,e):rbs'))) =
592 if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
593 then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
594 else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
596 simplifyBinds = concatMap simplifyBind