%%(c)TheUniversityofGlasgow2006%(c)TheGRASP/AQUAProject,GlasgowUniversity,1992-1998%TheDesugarer:turningHsSynintoCore.\begin{code}moduleDesugar(deSugar,deSugarExpr)whereimportDynFlagsimportStaticFlagsimportHscTypesimportHsSynimportTcRnTypesimportMkIfaceimportIdimportNameimportCoreSynimportPprCoreimportDsMonadimportDsExprimportDsBindsimportDsForeignimportDsExpr()-- Forces DsExpr to be compiled; DsBinds only-- depends on DsExpr.hi-boot.importModuleimportRdrNameimportNameSetimportVarSetimportRulesimportCoreLintimportCoreFVsimportErrUtilsimportOutputableimportSrcLocimportMaybesimportFastStringimportCoverageimportData.IORef\end{code}%************************************************************************%**%*Themainfunction:deSugar%**%************************************************************************\begin{code}-- | Main entry point to the desugarer.deSugar::HscEnv->ModLocation->TcGblEnv->IO(Messages,MaybeModGuts)-- Can modify PCS by faulting in more declarationsdeSugarhsc_envmod_loctcg_env@(TcGblEnv{tcg_mod=mod,tcg_src=hsc_src,tcg_type_env=type_env,tcg_imports=imports,tcg_exports=exports,tcg_keep=keep_var,tcg_rdr_env=rdr_env,tcg_fix_env=fix_env,tcg_inst_env=inst_env,tcg_fam_inst_env=fam_inst_env,tcg_warns=warns,tcg_anns=anns,tcg_binds=binds,tcg_fords=fords,tcg_rules=rules,tcg_insts=insts,tcg_fam_insts=fam_insts,tcg_hpc=other_hpc_info})=do{letdflags=hsc_dflagshsc_env;showPassdflags"Desugar"-- Desugar the program;letexport_set=availsToNameSetexports;letauto_scc=mkAutoSccdflagsmodexport_set;lettarget=hscTargetdflags;lethpcInfo=emptyHpcInfoother_hpc_info;(msgs,mb_res)<-casetargetofHscNothing->return(emptyMessages,Just([],[],NoStubs,hpcInfo,emptyModBreaks))_->do(binds_cvr,ds_hpc_info,modBreaks)<-if(opt_Hpc||target==HscInterpreted)&&(not(isHsBoothsc_src))thenaddCoverageTicksToBindsdflagsmodmod_loc(typeEnvTyConstype_env)bindselsereturn(binds,hpcInfo,emptyModBreaks)initDshsc_envmodrdr_envtype_env$docore_prs<-dsTopLHsBindsauto_sccbinds_cvr(ds_fords,foreign_prs)<-dsForeignsfordsletall_prs=foreign_prs++core_prsds_rules<-mapMdsRulerulesreturn(all_prs,catMaybesds_rules,ds_fords,ds_hpc_info,modBreaks);casemb_resof{Nothing->return(msgs,Nothing);Just(all_prs,ds_rules,ds_fords,ds_hpc_info,modBreaks)->do{-- Add export flags to bindingskeep_alive<-readIORefkeep_var;letfinal_prs=addExportFlagstargetexport_setkeep_aliveall_prsds_rulesds_binds=[Recfinal_prs]-- Notice that we put the whole lot in a big Rec, even the foreign binds-- When compiling PrelFloat, which defines data Float = F# Float#-- we want F# to be in scope in the foreign marshalling code!-- You might think it doesn't matter, but the simplifier brings all top-level-- things into the in-scope set before simplifying; so we get no unfolding for F#!-- Lint result if necessary;endPassdflags"Desugar"Opt_D_dump_dsds_binds-- Dump output;doIfSet(doptOpt_D_dump_dsdflags)(printDump(ppr_ds_rulesds_rules));used_names<-mkUsedNamestcg_env;deps<-mkDependenciestcg_env;letmod_guts=ModGuts{mg_module=mod,mg_boot=isHsBoothsc_src,mg_exports=exports,mg_deps=deps,mg_used_names=used_names,mg_dir_imps=imp_modsimports,mg_rdr_env=rdr_env,mg_fix_env=fix_env,mg_warns=warns,mg_anns=anns,mg_types=type_env,mg_insts=insts,mg_fam_insts=fam_insts,mg_inst_env=inst_env,mg_fam_inst_env=fam_inst_env,mg_rules=ds_rules,mg_binds=ds_binds,mg_foreign=ds_fords,mg_hpc_info=ds_hpc_info,mg_modBreaks=modBreaks,mg_vect_info=noVectInfo};return(msgs,Justmod_guts)}}}mkAutoScc::DynFlags->Module->NameSet->AutoSccmkAutoSccdflagsmodexports|notopt_SccProfilingOn-- No profiling=NoSccs-- Add auto-scc on all top-level things|doptOpt_AutoSccsOnAllToplevsdflags=AddSccsmod(\id->not$isDerivedOccName$getOccNameid)-- See #1641. This is pretty yucky, but I can't see a better way-- to identify compiler-generated Ids, and at least this should-- catch them all.-- Only on exported things|doptOpt_AutoSccsOnExportedToplevsdflags=AddSccsmod(\id->idNameid`elemNameSet`exports)|otherwise=NoSccsdeSugarExpr::HscEnv->Module->GlobalRdrEnv->TypeEnv->LHsExprId->IO(Messages,MaybeCoreExpr)-- Prints its own errors; returns Nothing if error occurreddeSugarExprhsc_envthis_modrdr_envtype_envtc_expr=doletdflags=hsc_dflagshsc_envshowPassdflags"Desugar"-- Do desugaring(msgs,mb_core_expr)<-initDshsc_envthis_modrdr_envtype_env$dsLExprtc_exprcasemb_core_exprofNothing->return(msgs,Nothing)Justexpr->do-- Dump outputdumpIfSet_dyndflagsOpt_D_dump_ds"Desugared"(pprCoreExprexpr)return(msgs,Justexpr)-- addExportFlags-- Set the no-discard flag if either -- a) the Id is exported-- b) it's mentioned in the RHS of an orphan rule-- c) it's in the keep-alive set---- It means that the binding won't be discarded EVEN if the binding-- ends up being trivial (v = w) -- the simplifier would usually just -- substitute w for v throughout, but we don't apply the substitution to-- the rules (maybe we should?), so this substitution would make the rule-- bogus.-- You might wonder why exported Ids aren't already marked as such;-- it's just because the type checker is rather busy already and-- I didn't want to pass in yet another mapping.addExportFlags::HscTarget->NameSet->NameSet->[(Id,t)]->[CoreRule]->[(Id,t)]addExportFlagstargetexportskeep_aliveprsrules=[(add_exportbndr,rhs)|(bndr,rhs)<-prs]whereadd_exportbndr|dont_discardbndr=setIdExportedbndr|otherwise=bndrorph_rhs_fvs=unionVarSets[ruleRhsFreeVarsrule|rule<-rules,not(isLocalRulerule)]-- A non-local rule keeps alive the free vars of its right-hand side. -- (A "non-local" is one whose head function is not locally defined.)-- Local rules are (later, after gentle simplification) -- attached to the Id, and that keeps the rhs free vars alive.dont_discardbndr=is_exportedname||name`elemNameSet`keep_alive||bndr`elemVarSet`orph_rhs_fvswherename=idNamebndr-- In interactive mode, we don't want to discard any top-level-- entities at all (eg. do not inline them away during-- simplification), and retain them all in the TypeEnv so they are-- available from the command line.---- isExternalName separates the user-defined top-level names from those-- introduced by the type checker.is_exported::Name->Boolis_exported|target==HscInterpreted=isExternalName|otherwise=(`elemNameSet`exports)ppr_ds_rules::[CoreRule]->SDocppr_ds_rules[]=emptyppr_ds_rulesrules=text""$$text"-------------- DESUGARED RULES -----------------"$$pprRulesrules\end{code}%************************************************************************%**%*Desugaringtransformationrules%**%************************************************************************\begin{code}dsRule::LRuleDeclId->DsM(MaybeCoreRule)dsRule(Lloc(HsRulenameactvarslhs_tv_lhsrhs_fv_rhs))=putSrcSpanDsloc$do{letbndrs'=[var|RuleBndr(L_var)<-vars];lhs'<-dsLExprlhs;rhs'<-dsLExprrhs-- Substitute the dict bindings eagerly,-- and take the body apart into a (f args) form;casedecomposeRuleLhs(mkLamsbndrs'lhs')of{Nothing->do{warnDsmsg;returnNothing};Just(bndrs,fn_id,args)->do{letlocal_rule=isLocalIdfn_id-- NB: isLocalId is False of implicit Ids. This is good becuase-- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code genfn_name=idNamefn_idrule=Rule{ru_name=name,ru_fn=fn_name,ru_act=act,ru_bndrs=bndrs,ru_args=args,ru_rhs=rhs',ru_rough=roughTopNamesargs,ru_local=local_rule};return(Justrule)}}}wheremsg=hang(ptext(sLit"RULE left-hand side too complicated to desugar; ignored"))2(pprlhs)\end{code}