X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=a870cd433cbe903e9bb2ff4b05dc2d68785d0a9b;hb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;hp=da8603176d8dd44fecbb835f0e835bae04d6f479;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index da86031..a870cd4 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -1,100 +1,153 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Desugar]{@deSugar@: the main function} \begin{code} -#include "HsVersions.h" - -module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where +module Desugar ( deSugar ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsBinds, HsExpr ) -import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) +import CmdLineOpts ( opt_D_dump_ds ) +import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) +import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl ) +import TcModule ( TcResults(..) ) import CoreSyn - +import Rules ( ProtoCoreRule(..), pprProtoCoreRule ) +import Subst ( substExpr, mkSubst ) import DsMonad -import DsBinds ( dsBinds, dsInstBinds ) +import DsExpr ( dsExpr ) +import DsBinds ( dsMonoBinds, AutoScc(..) ) +import DsForeign ( dsForeigns ) import DsUtils - -import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) -import CoreLift ( liftCoreBindings ) -import CoreLint ( lintCoreBindings ) -import Id ( nullIdEnv, mkIdEnv ) -import PprStyle ( PprStyle(..) ) -import UniqSupply ( splitUniqSupply ) +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 VarEnv +import VarSet +import Bag ( isEmptyBag, unionBags ) +import CmdLineOpts ( opt_SccProfilingOn ) +import CoreLint ( beginPass, endPass ) +import ErrUtils ( doIfSet, pprBagOfWarnings ) +import Outputable +import UniqSupply ( splitUniqSupply, UniqSupply ) \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 - -> FAST_STRING -- module name +deSugar :: Module + -> UniqSupply + -> 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" + -- 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 + + -- Display any warnings + doIfSet (not (isEmptyBag ds_warns)) + (printErrs (pprBagOfWarnings ds_warns)) + + -- Lint result if necessary + endPass "Desugar" opt_D_dump_ds ds_binds + + doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules)) + + return result + +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) -> + let + ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds + fe_binders = bindersOfBinds fe_binds + 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 + auto_scc | opt_SccProfilingOn = TopLevel + | otherwise = NoSccs + +ppr_ds_rules [] = empty +ppr_ds_rules rules + = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ + vcat (map pprProtoCoreRule rules) +\end{code} - -> (TypecheckedHsBinds, -- input: recsel, class, instance, and value - TypecheckedHsBinds, -- bindings; see "tcModule" (which produces - TypecheckedHsBinds, -- them) - TypecheckedHsBinds, - [(Id, TypecheckedHsExpr)]) --- ToDo: handling of const_inst thingies is certainly WRONG *************************** - -> ([CoreBinding], -- output - Bag DsMatchContext) -- Shadowing complaints +%************************************************************************ +%* * +%* Desugaring transformation rules +%* * +%************************************************************************ -deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) +\begin{code} +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule +dsRule in_scope (IfaceRuleOut fn rule) + = returnDs (ProtoCoreRule False {- non-local -} fn rule) + +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)) + where + tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] + all_vars = in_scope `unionVarSet` mkVarSet tpl_vars + +ds_lhs all_vars lhs = let - (us0, us0a) = splitUniqSupply us - (us1, us1a) = splitUniqSupply us0a - (us2, us2a) = splitUniqSupply us1a - (us3, us3a) = splitUniqSupply us2a - (us4, us5) = splitUniqSupply us3a - - auto_meth = opt_AutoSccsOnAllToplevs - auto_top = opt_AutoSccsOnAllToplevs - || opt_AutoSccsOnExportedToplevs - - ((core_const_prs, consts_pairs), shadows1) - = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) - - consts_env = mkIdEnv consts_pairs - - (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds False clas_binds) - core_clas_prs = pairsFromCoreBinds core_clas_binds - - (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds) - core_inst_prs = pairsFromCoreBinds core_inst_binds - - (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds auto_top val_binds) - core_val_pairs = pairsFromCoreBinds core_val_binds - - (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds) - core_recsel_prs = pairsFromCoreBinds core_recsel_binds - - final_binds - = if (null core_clas_prs && null core_inst_prs - && null core_recsel_prs {-???dont know???-} && null core_const_prs) then - -- we don't have to make the whole thing recursive - core_clas_binds ++ core_val_binds - - else -- gotta make it recursive (sigh) - [Rec (core_clas_prs ++ core_inst_prs - ++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)] - - lift_final_binds = liftCoreBindings us5 final_binds - - really_final_binds = if opt_DoCoreLinting - then lintCoreBindings PprDebug "Desugarer" False lift_final_binds - else lift_final_binds - - shadows = shadows1 `unionBags` shadows2 `unionBags` - shadows3 `unionBags` shadows4 `unionBags` shadows5 + (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 + + 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 - (really_final_binds, shadows) + 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}