Commit 539b5729 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent a47d62f7
......@@ -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,
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment