X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=1745615d5f9e98dfdae8e086fb7f0cf1ae302e2a;hb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;hp=4fc7be46e73bf17ee0f071469d0425b16c6ec344;hpb=e1db55d8bd07c79bae30f548e597f709dd029155;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 4fc7be4..1745615 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,66 +8,154 @@ module Desugar ( deSugar ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_ds ) -import HsSyn ( MonoBinds ) -import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) +import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), + HsExpr(..), HsBinds(..), MonoBinds(..) ) +import TcHsSyn ( TypecheckedRuleDecl ) +import TcModule ( TcResults(..) ) +import Id ( Id ) import CoreSyn +import PprCore ( pprIdCoreRule ) +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 Bag ( isEmptyBag, unionBags ) -import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) -import CoreLint ( beginPass, endPass ) +import Module ( Module ) +import Id ( Id ) +import VarEnv +import VarSet +import Bag ( isEmptyBag ) +import CoreLint ( showPass, endPass ) import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable -import UniqSupply ( splitUniqSupply, UniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) +import HscTypes ( HomeSymbolTable ) \end{code} +%************************************************************************ +%* * +%* The main function: deSugar +%* * +%************************************************************************ + The only trick here is to get the @DsMonad@ stuff off to a good start. \begin{code} -deSugar :: UniqSupply -- name supply - -> ValueEnv -- value env - -> Module -- module name - -> TypecheckedMonoBinds - -> [TypecheckedForeignDecl] - -> IO ([CoreBind], SDoc, SDoc) -- output - -deSugar us global_val_env mod_name all_binds fo_decls = do - beginPass "Desugar" +deSugar :: DynFlags + -> Module -> PrintUnqualified + -> HomeSymbolTable + -> TcResults + -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr]) + +deSugar dflags mod_name unqual hst + (TcResults {tc_env = global_val_env, + tc_pcs = pcs, + tc_binds = all_binds, + tc_rules = rules, + tc_fords = fo_decls}) + = do + showPass dflags "Desugar" + us <- mkSplitUniqSupply 'd' + -- Do desugaring - let (core_prs, ds_warns1) = initDs us1 global_val_env module_and_group - (dsMonoBinds auto_scc all_binds []) - auto_scc | opt_SccProfilingOn = TopLevel - | otherwise = NoSccs - ds_binds' = [Rec core_prs] + 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 unqual (pprBagOfWarnings ds_warns)) - ((fi_binds, fe_binds, h_code, c_code), ds_warns2) = - initDs us3 global_val_env module_and_group (dsForeigns mod_name fo_decls) + -- Lint result if necessary + let do_dump_ds = dopt Opt_D_dump_ds dflags + endPass dflags "Desugar" do_dump_ds ds_binds - ds_binds = fi_binds ++ ds_binds' ++ fe_binds + -- Dump output + doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) - ds_warns = ds_warns1 `unionBags` ds_warns2 + return result - -- Display any warnings - doIfSet (not (isEmptyBag ds_warns)) - (printErrs (pprBagOfWarnings ds_warns)) +dsProgram mod_name all_binds rules fo_decls + = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> + 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#! - -- Lint result if necessary - endPass "Desugar" opt_D_dump_ds ds_binds - return (ds_binds, h_code, c_code) + local_binders = mkVarSet (bindersOfBinds ds_binds) + in + mapDs (dsRule local_binders) rules `thenDs` \ rules' -> + returnDs (ds_binds, rules', h_code, c_code, fe_binders) where - (us1, us2) = splitUniqSupply us - (us3, us4) = splitUniqSupply us2 + auto_scc | opt_SccProfilingOn = TopLevel + | otherwise = NoSccs + +ppr_ds_rules [] = empty +ppr_ds_rules rules + = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ + vcat (map pprIdCoreRule rules) +\end{code} + + +%************************************************************************ +%* * +%* Desugaring transformation rules +%* * +%************************************************************************ + +\begin{code} +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) +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 (fn, Rule name tpl_vars args core_rhs) + where + 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) + in + ds_dict_binds dict_binds `thenDs` \ dict_binds' -> + dsExpr body `thenDs` \ body' -> + + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + let + subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds'] + [ContEx subst_env rhs | (id,rhs) <- dict_binds'] + -- Note recursion here... substitution won't terminate + -- if there is genuine recursion... which there isn't - 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 + subst = mkSubst all_vars subst_env + body'' = substExpr subst body' + in + + -- Now unpack the resulting body + let + pair = case collectArgs body'' of + (Var fn, args) -> (fn, args) + other -> pprPanic "dsRule" (ppr lhs) + in + returnDs pair +ds_dict_binds EmptyMonoBinds = returnDs [] +ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 -> + ds_dict_binds b2 `thenDs` \ env2 -> + returnDs (env1 ++ env2) +ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' -> + returnDs [(id,rhs')] \end{code}