X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=0765a94f9569dfe1dc800b075c9bcfd9307e7fcf;hb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;hp=557ac73cc0658f4a72f598326850c0f4b4ff6f3a;hpb=fe69f3c1d6062b90635963aa414c33951bf18427;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 557ac73..0765a94 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -4,16 +4,18 @@ \section[Desugar]{@deSugar@: the main function} \begin{code} -module Desugar ( deSugar ) where +module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_ds ) -import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import TcHsSyn ( TypecheckedRuleDecl ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) +import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), + HsExpr(..), HsBinds(..), MonoBinds(..) ) +import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) import TcModule ( TcResults(..) ) +import Id ( Id ) import CoreSyn -import Rules ( ProtoCoreRule(..), pprProtoCoreRule ) +import PprCore ( pprIdCoreRule, pprCoreExpr ) import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad import DsExpr ( dsExpr ) @@ -22,14 +24,16 @@ import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module ( Module ) +import Id ( Id ) +import NameEnv ( lookupNameEnv ) import VarEnv import VarSet import Bag ( isEmptyBag ) -import CmdLineOpts ( opt_SccProfilingOn ) -import CoreLint ( beginPass, endPass ) -import ErrUtils ( doIfSet, pprBagOfWarnings ) +import CoreLint ( showPass, endPass ) +import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings ) import Outputable -import UniqSupply ( UniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) +import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, ) \end{code} %************************************************************************ @@ -42,44 +46,95 @@ The only trick here is to get the @DsMonad@ stuff off to a good start. \begin{code} -deSugar :: Module - -> UniqSupply +deSugar :: DynFlags + -> PersistentCompilerState -> HomeSymbolTable + -> Module -> PrintUnqualified -> TcResults - -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr]) - -deSugar mod_name us (TcResults {tc_env = global_val_env, - tc_binds = all_binds, - tc_rules = rules, - tc_fords = fo_decls}) - = do - beginPass "Desugar" + -> IO ([CoreBind], [(Id,CoreRule)], (SDoc, SDoc, [CoreBndr])) + +deSugar dflags pcs hst mod_name unqual + (TcResults {tc_env = local_type_env, + tc_binds = all_binds, + tc_rules = rules, + tc_fords = fo_decls}) + = do { showPass dflags "Desugar" + ; us <- mkSplitUniqSupply 'd' + -- Do desugaring - let (result, ds_warns) = - initDs us global_val_env mod_name - (dsProgram mod_name all_binds rules fo_decls) - (ds_binds, ds_rules, _, _, _) = result + ; let (result, ds_warns) = initDs dflags us lookup 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)) - -- Display any warnings - doIfSet (not (isEmptyBag ds_warns)) - (printErrs (pprBagOfWarnings ds_warns)) + -- Lint result if necessary + ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds - -- Lint result if necessary - endPass "Desugar" opt_D_dump_ds ds_binds + -- Dump output + ; doIfSet (dopt Opt_D_dump_ds dflags) + (printDump (ppr_ds_rules ds_rules)) - doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules)) + ; return result + } - return result + where + -- The lookup function passed to initDs is used for well-known Ids, + -- such as fold, build, cons etc, so the chances are + -- it'll be found in the package symbol table. That's + -- why we don't merge all these tables + pte = pcs_PTE pcs + lookup n = case lookupType hst pte n of { + Just (AnId v) -> v ; + other -> + case lookupNameEnv local_type_env n of + Just (AnId v) -> v ; + other -> pprPanic "Desugar: lookup:" (ppr n) + } + +deSugarExpr :: DynFlags + -> PersistentCompilerState -> HomeSymbolTable + -> Module -> PrintUnqualified + -> TypecheckedHsExpr + -> IO CoreExpr +deSugarExpr dflags pcs hst mod_name unqual tc_expr + = do { showPass dflags "Desugar" + ; us <- mkSplitUniqSupply 'd' + + -- Do desugaring + ; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr) + + -- Display any warnings + ; doIfSet (not (isEmptyBag ds_warns)) + (printErrs unqual (pprBagOfWarnings ds_warns)) + + -- Dump output + ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr) + + ; return core_expr + } + where + pte = pcs_PTE pcs + lookup n = case lookupType hst pte n of + Just (AnId v) -> v + other -> pprPanic "Desugar: lookup:" (ppr n) 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) -> + dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) -> let - ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds - fe_binders = bindersOfBinds fe_binds + 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 mapDs (dsRule local_binders) rules `thenDs` \ rules' -> - returnDs (ds_binds, rules', h_code, c_code, fe_binders) + returnDs (ds_binds, rules', (h_code, c_code, fe_binders)) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs @@ -87,7 +142,7 @@ dsProgram mod_name all_binds rules fo_decls ppr_ds_rules [] = empty ppr_ds_rules rules = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ - vcat (map pprProtoCoreRule rules) + vcat (map pprIdCoreRule rules) \end{code} @@ -98,16 +153,12 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule -dsRule in_scope (IfaceRuleOut fn rule) - = returnDs (ProtoCoreRule False {- non-local -} fn rule) - +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 (ProtoCoreRule True {- local -} fn - (Rule name tpl_vars args 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)