X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=64fff0d0129fe1d34798e3e7f96b87ad7ebe0c2f;hb=99e1bcf5cf97b3b69df99ec7b2bfb9b1076d3516;hp=8387146f17a89bcead7809cef9456f5547d3de27;hpb=9bcd95bad83ee937c178970e8b729732e680fe1e;p=ghc-hetmet.git diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 8387146..64fff0d 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -27,10 +27,8 @@ import DsExpr () -- Forces DsExpr to be compiled; DsBinds only import Module import RdrName import NameSet -import VarSet import Rules -import CoreLint -import CoreFVs +import CoreMonad ( endPass, CoreToDo(..) ) import ErrUtils import Outputable import SrcLoc @@ -48,6 +46,7 @@ import Data.IORef %************************************************************************ \begin{code} +-- | Main entry point to the desugarer. deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) -- Can modify PCS by faulting in more declarations @@ -77,7 +76,7 @@ deSugar hsc_env -- Desugar the program ; let export_set = availsToNameSet exports - ; let auto_scc = mkAutoScc mod export_set + ; let auto_scc = mkAutoScc dflags mod export_set ; let target = hscTarget dflags ; let hpcInfo = emptyHpcInfo other_hpc_info ; (msgs, mb_res) @@ -106,7 +105,7 @@ deSugar hsc_env { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let final_prs = addExportFlags target export_set - keep_alive all_prs ds_rules + keep_alive all_prs ds_binds = [Rec final_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# @@ -115,7 +114,7 @@ deSugar hsc_env -- things into the in-scope set before simplifying; so we get no unfolding for F#! -- Lint result if necessary - ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds + ; endPass dflags CoreDesugar ds_binds ds_rules -- Dump output ; doIfSet (dopt Opt_D_dump_ds dflags) @@ -150,16 +149,18 @@ deSugar hsc_env ; return (msgs, Just mod_guts) }}} -mkAutoScc :: Module -> NameSet -> AutoScc -mkAutoScc mod exports +mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc +mkAutoScc dflags mod exports | not opt_SccProfilingOn -- No profiling = NoSccs - | opt_AutoSccsOnAllToplevs -- Add auto-scc on all top-level things + -- Add auto-scc on all top-level things + | dopt Opt_AutoSccsOnAllToplevs dflags = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id) -- 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. - | opt_AutoSccsOnExportedToplevs -- Only on exported things + -- Only on exported things + | dopt Opt_AutoSccsOnExportedToplevs dflags = AddSccs mod (\id -> idName id `elemNameSet` exports) | otherwise = NoSccs @@ -203,26 +204,17 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do -- 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] +addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [(Id, t)] -addExportFlags target exports keep_alive prs rules +addExportFlags target exports keep_alive prs = [(add_export bndr, rhs) | (bndr,rhs) <- prs] where add_export bndr | dont_discard bndr = setIdExported bndr | otherwise = bndr - orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule - | rule <- rules, - not (isLocalRule rule) ] - -- 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_discard bndr = is_exported name || name `elemNameSet` keep_alive - || bndr `elemVarSet` orph_rhs_fvs where name = idName bndr @@ -240,7 +232,7 @@ addExportFlags target exports keep_alive prs rules ppr_ds_rules :: [CoreRule] -> SDoc ppr_ds_rules [] = empty ppr_ds_rules rules - = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ + = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$ pprRules rules \end{code} @@ -257,7 +249,10 @@ dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- dsLExpr lhs + + ; lhs' <- unsetOptM Opt_EnableRewriteRules $ + dsLExpr lhs -- Note [Desugaring RULE lhss] + ; rhs' <- dsLExpr rhs -- Substitute the dict bindings eagerly, @@ -270,15 +265,21 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) -- 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 gen - fn_name = idName fn_id - - rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act, - ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', - ru_rough = roughTopNames args, - ru_local = local_rule } + fn_name = idName fn_id + rule = mkRule local_rule name act fn_name bndrs args rhs' ; return (Just rule) } } } where msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored")) 2 (ppr lhs) \end{code} + +Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. See DsExpr.dsExplicitList. + +That keeps the desugaring of list comprehensions simple too.