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.

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index ab9f8c7..45baa67 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -17,7 +17,6 @@ import MkIface
 import Id
 import Name
 import CoreSyn
 import Id
 import Name
 import CoreSyn

-import OccurAnal

 import PprCore
 import DsMonad
 import DsExpr
 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 $ 
 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
 
        ; 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
        -- 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, 
        { 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 (file)
--- 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 DsMonad
 import DsGRHSs
 import DsUtils

+import OccurAnal

 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things

@@ -32,12 +33,11 @@ import CoreFVs
 
 import TcHsSyn ( mkArbitraryType )     -- Mis-placed?
 import TcType
 
 import TcHsSyn ( mkArbitraryType )     -- Mis-placed?
 import TcType

-import OccurAnal

 import CostCentre
 import Module
 import Id
 import Name    ( localiseName )
 import CostCentre
 import Module
 import Id
 import Name    ( localiseName )

-import Var     ( TyVar )
+import Var     ( Var, TyVar )

 import VarSet
 import Rules
 import VarEnv
 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
     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,
 
        ; 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))
                                (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 
   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}
 %************************************************************************
 
 \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 
 -- 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
   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
         -- 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
         = case collectArgs (simpleSubst env body) of
             (Var fn, args) -> Just (fn, args)
             _              -> Nothing