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
22 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
28 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
29 -- depends on DsExpr.hi-boot.
35 import CoreMonad ( endPass, CoreToDo(..) )
53 %************************************************************************
55 %* The main function: deSugar
57 %************************************************************************
61 -- | Main entry point to the desugarer.
62 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
63 -- Can modify PCS by faulting in more declarations
67 tcg_env@(TcGblEnv { tcg_mod = mod,
69 tcg_type_env = type_env,
70 tcg_imports = imports,
71 tcg_exports = exports,
73 tcg_rdr_env = rdr_env,
74 tcg_fix_env = fix_env,
75 tcg_inst_env = inst_env,
76 tcg_fam_inst_env = fam_inst_env,
80 tcg_imp_specs = imp_specs,
81 tcg_ev_binds = ev_binds,
86 tcg_fam_insts = fam_insts,
87 tcg_hpc = other_hpc_info })
89 = do { let dflags = hsc_dflags hsc_env
90 ; showPass dflags "Desugar"
92 -- Desugar the program
93 ; let export_set = availsToNameSet exports
94 ; let auto_scc = mkAutoScc dflags mod export_set
95 ; let target = hscTarget dflags
96 ; let hpcInfo = emptyHpcInfo other_hpc_info
100 return (emptyMessages,
101 Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
128 (binds_cvr,ds_hpc_info, modBreaks)
130 || target == HscInterpreted)
131 && (not (isHsBoot hsc_src))
132 then addCoverageTicksToBinds dflags mod mod_loc
133 (typeEnvTyCons type_env) binds
134 else return (binds, hpcInfo, emptyModBreaks)
135 initDs hsc_env mod rdr_env type_env $ do
136 do { ds_ev_binds <- dsEvBinds ev_binds
137 ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
138 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
139 ; (ds_fords, foreign_prs) <- dsForeigns fords
140 ; ds_rules <- mapMaybeM dsRule rules
141 ; ds_vects <- mapM dsVect vects
142 ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
143 ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
144 ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
145 ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
146 ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
147 ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
148 ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
149 ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
150 ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
151 ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
152 ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
153 ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
154 ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
155 ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
156 ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
157 ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
158 ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
159 ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
160 ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
161 ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
162 ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
163 ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
164 ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
165 ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
166 ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
167 ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
169 | opt_Hpc = hpcInitCode mod ds_hpc_info
171 ; return ( ds_ev_binds
172 , foreign_prs `appOL` core_prs `appOL` spec_prs
173 , spec_rules ++ ds_rules, ds_vects
174 , ds_fords `appendStubC` hpc_init
175 , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
178 , hetmet_flattened_id
180 , hetmet_PGArrow_unit
181 , hetmet_PGArrow_tensor
182 , hetmet_PGArrow_exponent
189 , hetmet_pga_uncancell
190 , hetmet_pga_uncancelr
203 Nothing -> return (msgs, Nothing) ;
204 Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
205 , hetmet_brak, hetmet_esc
208 , hetmet_flattened_id
210 , hetmet_PGArrow_unit
211 , hetmet_PGArrow_tensor
212 , hetmet_PGArrow_exponent
219 , hetmet_pga_uncancell
220 , hetmet_pga_uncancelr
229 , hetmet_pga_curryr) -> do
231 { -- Add export flags to bindings
232 keep_alive <- readIORef keep_var
233 ; let (rules_for_locals, rules_for_imps)
234 = partition isLocalRule all_rules
235 final_prs = addExportFlagsAndRules target
236 export_set keep_alive rules_for_locals (fromOL all_prs)
238 final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
239 in if dopt Opt_F_simpleopt_before_flatten dflags
241 else simplifyBinds comb
242 -- Notice that we put the whole lot in a big Rec, even the foreign binds
243 -- When compiling PrelFloat, which defines data Float = F# Float#
244 -- we want F# to be in scope in the foreign marshalling code!
245 -- You might think it doesn't matter, but the simplifier brings all top-level
246 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
248 -- Lint result if necessary, and print
249 ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
250 (vcat [ pprCoreBindings final_pgm
251 , pprRules rules_for_imps ])
253 ; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
254 then simpleOptPgm dflags final_pgm rules_for_imps
255 else return (final_pgm, rules_for_imps)
257 ; ds_binds <- if dopt Opt_F_coqpass dflags
258 then do { us <- mkSplitUniqSupply '~'
259 ; let do_flatten = dopt Opt_F_flatten dflags
260 ; let do_skolemize = dopt Opt_F_skolemize dflags
261 ; return (coqPassCoreToCore
273 hetmet_PGArrow_tensor
274 hetmet_PGArrow_exponent
293 else return final_pgm
295 ; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags
296 then return (ds_binds, rules_for_imps')
297 else simpleOptPgm dflags ds_binds rules_for_imps'
298 -- The simpleOptPgm gets rid of type
299 -- bindings plus any stupid dead code
301 ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
303 ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
305 ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
307 ; let used_names = mkUsedNames tcg_env
308 ; deps <- mkDependencies tcg_env
310 ; let mod_guts = ModGuts {
312 mg_boot = isHsBoot hsc_src,
313 mg_exports = exports,
315 mg_used_names = used_names,
316 mg_dir_imps = imp_mods imports,
317 mg_rdr_env = rdr_env,
318 mg_fix_env = fix_env,
323 mg_fam_insts = fam_insts,
324 mg_inst_env = inst_env,
325 mg_fam_inst_env = fam_inst_env,
326 mg_rules = ds_rules_for_imps,
327 mg_binds = ds_binds',
328 mg_foreign = ds_fords,
329 mg_hpc_info = ds_hpc_info,
330 mg_modBreaks = modBreaks,
331 mg_vect_decls = ds_vects,
332 mg_vect_info = noVectInfo
334 ; return (msgs, Just mod_guts)
337 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
339 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
340 ; let (spec_binds, spec_rules) = unzip spec_prs
341 ; return (concatOL spec_binds, spec_rules) }
343 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
344 -- Top-level bindings can include coercion bindings, but not via superclasses
345 -- See Note [Top-level evidence]
346 combineEvBinds [] val_prs
348 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
349 | isId b = combineEvBinds bs ((b,r):val_prs)
350 | otherwise = NonRec b r : combineEvBinds bs val_prs
351 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
352 = combineEvBinds bs (prs ++ val_prs)
353 combineEvBinds (CaseEvBind x _ _ : _) _
354 = pprPanic "topEvBindPairs" (ppr x)
357 Note [Top-level evidence]
358 ~~~~~~~~~~~~~~~~~~~~~~~~~
359 Top-level evidence bindings may be mutually recursive with the top-level value
360 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
361 because the occurrence analyser doesn't teke account of type/coercion variables
362 when computing dependencies.
364 So we pull out the type/coercion variables (which are in dependency order),
369 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
370 mkAutoScc dflags mod exports
371 | not opt_SccProfilingOn -- No profiling
373 -- Add auto-scc on all top-level things
374 | dopt Opt_AutoSccsOnAllToplevs dflags
375 = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
376 -- See #1641. This is pretty yucky, but I can't see a better way
377 -- to identify compiler-generated Ids, and at least this should
379 -- Only on exported things
380 | dopt Opt_AutoSccsOnExportedToplevs dflags
381 = AddSccs mod (\id -> idName id `elemNameSet` exports)
385 deSugarExpr :: HscEnv
386 -> Module -> GlobalRdrEnv -> TypeEnv
388 -> IO (Messages, Maybe CoreExpr)
389 -- Prints its own errors; returns Nothing if error occurred
391 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
392 let dflags = hsc_dflags hsc_env
393 showPass dflags "Desugar"
396 (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
400 Nothing -> return (msgs, Nothing)
404 dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
406 return (msgs, Just expr)
409 %************************************************************************
411 %* Add rules and export flags to binders
413 %************************************************************************
416 addExportFlagsAndRules
417 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
418 -> [(Id, t)] -> [(Id, t)]
419 addExportFlagsAndRules target exports keep_alive rules prs
422 add_one bndr = add_rules name (add_export name bndr)
426 ---------- Rules --------
427 -- See Note [Attach rules to local ids]
428 -- NB: the binder might have some existing rules,
429 -- arising from specialisation pragmas
431 | Just rules <- lookupNameEnv rule_base name
432 = bndr `addIdSpecialisations` rules
435 rule_base = extendRuleBaseList emptyRuleBase rules
437 ---------- Export flag --------
438 -- See Note [Adding export flags]
440 | dont_discard name = setIdExported bndr
443 dont_discard :: Name -> Bool
444 dont_discard name = is_exported name
445 || name `elemNameSet` keep_alive
447 -- In interactive mode, we don't want to discard any top-level
448 -- entities at all (eg. do not inline them away during
449 -- simplification), and retain them all in the TypeEnv so they are
450 -- available from the command line.
452 -- isExternalName separates the user-defined top-level names from those
453 -- introduced by the type checker.
454 is_exported :: Name -> Bool
455 is_exported | target == HscInterpreted = isExternalName
456 | otherwise = (`elemNameSet` exports)
460 Note [Adding export flags]
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~
462 Set the no-discard flag if either
463 a) the Id is exported
464 b) it's mentioned in the RHS of an orphan rule
465 c) it's in the keep-alive set
467 It means that the binding won't be discarded EVEN if the binding
468 ends up being trivial (v = w) -- the simplifier would usually just
469 substitute w for v throughout, but we don't apply the substitution to
470 the rules (maybe we should?), so this substitution would make the rule
473 You might wonder why exported Ids aren't already marked as such;
474 it's just because the type checker is rather busy already and
475 I didn't want to pass in yet another mapping.
477 Note [Attach rules to local ids]
478 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
479 Find the rules for locally-defined Ids; then we can attach them
480 to the binders in the top-level bindings
483 - It makes the rules easier to look up
484 - It means that transformation rules and specialisations for
485 locally defined Ids are handled uniformly
486 - It keeps alive things that are referred to only from a rule
487 (the occurrence analyser knows about rules attached to Ids)
488 - It makes sure that, when we apply a rule, the free vars
489 of the RHS are more likely to be in scope
490 - The imported rules are carried in the in-scope set
491 which is extended on each iteration by the new wave of
492 local binders; any rules which aren't on the binding will
496 %************************************************************************
498 %* Desugaring transformation rules
500 %************************************************************************
503 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
504 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
506 do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
508 ; lhs' <- unsetOptM Opt_EnableRewriteRules $
509 unsetOptM Opt_WarnIdentities $
510 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
512 ; rhs' <- dsLExpr rhs
514 -- Substitute the dict bindings eagerly,
515 -- and take the body apart into a (f args) form
516 ; case decomposeRuleLhs bndrs' lhs' of {
517 Left msg -> do { warnDs msg; return Nothing } ;
518 Right (final_bndrs, fn_id, args) -> do
520 { let is_local = isLocalId fn_id
521 -- NB: isLocalId is False of implicit Ids. This is good becuase
522 -- we don't want to attach rules to the bindings of implicit Ids,
523 -- because they don't show up in the bindings until just before code gen
524 fn_name = idName fn_id
525 final_rhs = simpleOptExpr rhs' -- De-crap it
526 rule = mkRule False {- Not auto -} is_local
527 name act fn_name final_bndrs args final_rhs
532 Note [Desugaring RULE left hand sides]
533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534 For the LHS of a RULE we do *not* want to desugar
535 [x] to build (\cn. x `c` n)
536 We want to leave explicit lists simply as chains
537 of cons's. We can achieve that slightly indirectly by
538 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
540 That keeps the desugaring of list comprehensions simple too.
544 Nor do we want to warn of conversion identities on the LHS;
545 the rule is precisly to optimise them:
546 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
549 %************************************************************************
551 %* Desugaring vectorisation declarations
553 %************************************************************************
556 dsVect :: LVectDecl Id -> DsM CoreVect
557 dsVect (L loc (HsVect v rhs))
559 do { rhs' <- fmapMaybeM dsLExpr rhs
560 ; return $ Vect (unLoc v) rhs'
562 -- dsVect (L loc (HsVect v Nothing))
563 -- = return $ Vect v Nothing
564 -- dsVect (L loc (HsVect v (Just rhs)))
565 -- = putSrcSpanDs loc $
566 -- do { rhs' <- dsLExpr rhs
567 -- ; return $ Vect v (Just rhs')
575 -- Simplification routines run before the flattener. We can't use
576 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
577 -- let-binding groups.
579 simplify :: Expr CoreBndr -> Expr CoreBndr
580 simplify (Var v) = Var v
581 simplify (App e1 e2) = App (simplify e1) (simplify e2)
582 simplify (Lit lit) = Lit lit
583 simplify (Note note e) = Note note (simplify e)
584 simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
586 else Cast (simplify e) co
587 simplify (Lam v e) = Lam v (simplify e)
588 simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
589 simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
590 simplify (Type t) = Type t
591 simplify (Coercion co) = Coercion co
593 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
594 simplifyBind (NonRec b e) = [NonRec b (simplify e)]
595 simplifyBind (Rec []) = []
596 simplifyBind (Rec (rbs@((b,e):rbs'))) =
597 if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
598 then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
599 else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
601 simplifyBinds = concatMap simplifyBind