X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=5090a9e872f84823bddca000f938b576073d4369;hb=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;hp=26ff4d2837eea20261c22f67b67c606e9611d98a;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 26ff4d2..5090a9e 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,32 +8,29 @@ module Desugar ( deSugar ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_ds ) -import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import HsCore ( UfRuleBody(..) ) -import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) +import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), + HsExpr(..), HsBinds(..), MonoBinds(..) ) +import TcHsSyn ( TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) import CoreSyn import Rules ( ProtoCoreRule(..), pprProtoCoreRule ) -import Subst ( substExpr, mkSubst ) +import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad import DsExpr ( dsExpr ) import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) -import DsUtils import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, moduleString ) -import Id ( Id ) -import Name ( isLocallyDefined ) +import Module ( Module ) import VarEnv import VarSet -import Bag ( isEmptyBag, unionBags ) -import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) +import Bag ( isEmptyBag ) import CoreLint ( beginPass, endPass ) import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable -import UniqSupply ( splitUniqSupply, UniqSupply ) +import UniqSupply ( UniqSupply ) +import HscTypes ( HomeSymbolTable ) \end{code} %************************************************************************ @@ -46,46 +43,54 @@ The only trick here is to get the @DsMonad@ stuff off to a good start. \begin{code} -deSugar :: Module +deSugar :: DynFlags + -> Module -> UniqSupply + -> HomeSymbolTable -> TcResults - -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc) - -deSugar mod_name us (TcResults {tc_env = global_val_env, - tc_binds = all_binds, - tc_rules = rules, - tc_fords = fo_decls}) + -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr]) + +deSugar dflags mod_name us hst + (TcResults {tc_env = global_val_env, + tc_pcs = pcs, + tc_binds = all_binds, + tc_rules = rules, + tc_fords = fo_decls}) = do - beginPass "Desugar" + beginPass dflags "Desugar" -- Do desugaring - let (result, ds_warns) = initDs us global_val_env module_and_group - (dsProgram mod_name all_binds rules fo_decls) - (ds_binds, ds_rules, _, _) = result + let (result, ds_warns) = + initDs dflags us (hst,pcs,global_val_env) mod_name + (dsProgram mod_name all_binds rules fo_decls) + (ds_binds, ds_rules, _, _, _) = result -- Display any warnings doIfSet (not (isEmptyBag ds_warns)) (printErrs (pprBagOfWarnings ds_warns)) -- Lint result if necessary - endPass "Desugar" opt_D_dump_ds ds_binds + let do_dump_ds = dopt Opt_D_dump_ds dflags + endPass dflags "Desugar" do_dump_ds ds_binds - doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules)) + doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) return result - where - module_and_group = (mod_name, grp_name) - grp_name = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> _PK_ (moduleString mod_name) -- default: module name dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> - dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) -> - mapDs dsRule rules `thenDs` \ rules' -> - let - ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds + dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) -> + let + ds_binds = [Rec (foreign_binds ++ core_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#! + + local_binders = mkVarSet (bindersOfBinds ds_binds) in - returnDs (ds_binds, rules', h_code, c_code) + mapDs (dsRule local_binders) rules `thenDs` \ rules' -> + returnDs (ds_binds, rules', h_code, c_code, fe_binders) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs @@ -104,25 +109,25 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule -dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc) - = returnDs (ProtoCoreRule False {- non-local -} fn - (Rule name all_vars args rhs)) +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule +dsRule in_scope (IfaceRuleOut fn rule) + = returnDs (ProtoCoreRule False {- non-local -} fn rule) -dsRule (RuleDecl name sig_tvs vars lhs rhs loc) +dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> dsExpr rhs `thenDs` \ core_rhs -> returnDs (ProtoCoreRule True {- local -} fn - (Rule name all_vars args core_rhs)) + (Rule name tpl_vars args core_rhs)) where - all_vars = sig_tvs ++ [var | RuleBndr var <- vars] + tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] + all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars) ds_lhs all_vars lhs = let (dict_binds, body) = case lhs of - (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body) - other -> (EmptyMonoBinds, lhs) + (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body) + other -> (EmptyMonoBinds, lhs) in ds_dict_binds dict_binds `thenDs` \ dict_binds' -> dsExpr body `thenDs` \ body' -> @@ -135,7 +140,7 @@ ds_lhs all_vars lhs -- Note recursion here... substitution won't terminate -- if there is genuine recursion... which there isn't - subst = mkSubst (mkVarSet all_vars) subst_env + subst = mkSubst all_vars subst_env body'' = substExpr subst body' in