From 539b572921068dc02cec4c5a71e8516958949336 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 15 Sep 2008 15:06:01 +0000 Subject: [PATCH] Refactor the desugaring of RULE lhss a bit This is just a tidy-up. Previously we were calling occurAnalyse twice on each LHS which was silly and a bit unclean too. This patch should have no overall effect, though. --- compiler/deSugar/Desugar.lhs | 11 ++++----- compiler/deSugar/DsBinds.lhs | 56 ++++++++++++++++++++++-------------------- 2 files changed, 34 insertions(+), 33 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index ab9f8c7..45baa67 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -17,7 +17,6 @@ import MkIface import Id import Name import CoreSyn -import OccurAnal import PprCore import DsMonad import DsExpr @@ -255,16 +254,16 @@ ppr_ds_rules rules 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] + do { let bndrs' = [var | RuleBndr (L _ var) <- vars] ; lhs' <- dsLExpr lhs ; rhs' <- dsLExpr rhs - ; case decomposeRuleLhs (occurAnalyseExpr lhs') of { - Nothing -> do { warnDs msg; return Nothing } ; - Just (fn_id, args) -> do - -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form + ; case decomposeRuleLhs (mkLams bndrs' lhs') of { + Nothing -> do { warnDs msg; return Nothing } ; + Just (bndrs, fn_id, args) -> do + { let local_rule = isLocalId fn_id -- NB: isLocalId is False of implicit Ids. This is good becuase -- we don't want to attach rules to the bindings of implicit Ids, diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 764e44b..a47551e 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -23,6 +23,7 @@ import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils +import OccurAnal import HsSyn -- lots of things import CoreSyn -- lots of things @@ -32,12 +33,11 @@ import CoreFVs import TcHsSyn ( mkArbitraryType ) -- Mis-placed? import TcType -import OccurAnal import CostCentre import Module import Id import Name ( localiseName ) -import Var ( TyVar ) +import Var ( Var, TyVar ) import VarSet import Rules import VarEnv @@ -333,27 +333,17 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name ; ds_spec_expr <- dsExpr spec_expr - ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr) - -- ds_spec_expr may look like - -- /\a. f a Int dOrdInt - -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl - -- The occurrence-analysis does two things - -- (a) identifies unused binders: Note [Unused spec binders] - -- (b) sorts dict bindings into NonRecs - -- so they can be inlined by decomposeRuleLhs - mb_lhs = decomposeRuleLhs body - - -- Check for dead binders: Note [Unused spec binders] - ; case filter isDeadBinder bndrs of { - bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } - | otherwise -> + ; case (decomposeRuleLhs ds_spec_expr) of { + Nothing -> do { warnDs decomp_msg; return Nothing } ; - case mb_lhs of - Nothing -> do { warnDs decomp_msg; return Nothing } + Just (bndrs, _fn, args) -> - Just (_, args) -> do { + -- Check for dead binders: Note [Unused spec binders] + case filter isDeadBinder bndrs of { + bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } + | otherwise -> do - f_body <- fix_up (Let mono_bind (Var mono_id)) + { f_body <- fix_up (Let mono_bind (Var mono_id)) ; let local_poly = setIdNotExported poly_id -- Very important to make the 'f' non-exported, @@ -372,7 +362,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (extra_dict_bndrs ++ bndrs) args (mkVarApps (Var spec_id) bndrs) ; return (Just (addInlineInfo inl spec_id spec_rhs, rule)) - } } } + } } } } where -- Bind to Any any of all_ptvs that aren't -- relevant for this particular function @@ -463,19 +453,31 @@ confused. Hence the use of 'localise' to make it Internal. %************************************************************************ \begin{code} -decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr]) +decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr]) +-- Take apart the LHS of a RULE. It's suuposed to look like +-- /\a. f a Int dOrdInt +-- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl +-- That is, the RULE binders are lambda-bound -- Returns Nothing if the LHS isn't of the expected shape decomposeRuleLhs lhs - = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict - -- bindings so we know if they are recursive + = case (decomp emptyVarEnv body) of + Nothing -> Nothing + Just (fn, args) -> Just (bndrs, fn, args) where + occ_lhs = occurAnalyseExpr lhs + -- The occurrence-analysis does two things + -- (a) identifies unused binders: Note [Unused spec binders] + -- (b) sorts dict bindings into NonRecs + -- so they can be inlined by 'decomp' + (bndrs, body) = collectBinders occ_lhs + -- Substitute dicts in the LHS args, so that there -- aren't any lets getting in the way -- Note that we substitute the function too; we might have this as -- a LHS: let f71 = M.f Int in f71 - go env (Let (NonRec dict rhs) body) - = go (extendVarEnv env dict (simpleSubst env rhs)) body - go env body + decomp env (Let (NonRec dict rhs) body) + = decomp (extendVarEnv env dict (simpleSubst env rhs)) body + decomp env body = case collectArgs (simpleSubst env body) of (Var fn, args) -> Just (fn, args) _ -> Nothing -- 1.7.10.4