Commit 1ed04090 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Make 'SPECIALISE instance' work again

This is a long-standing regression (Trac #7797), which meant that in
particular the Eq [Char] instance does not get specialised.
(The *methods* do, but the dictionary itself doesn't.)  So when you
call a function
     f :: Eq a => blah
on a string type (ie a=[Char]), 7.6 passes a dictionary of un-specialised
methods.

This only matters when calling an overloaded function from a
specialised context, but that does matter in some programs.  I
remember (though I cannot find the details) that Nick Frisby discovered
this to be the source of some pretty solid performanc regresisons.

Anyway it works now. The key change is that a DFunUnfolding now takes
a form that is both simpler than before (the DFunArg type is eliminated)
and more general:

data Unfolding
  = ...
  | DFunUnfolding {     -- The Unfolding of a DFunId
    			-- See Note [DFun unfoldings]
      		  	--     df = /\a1..am. \d1..dn. MkD t1 .. tk
                        --                                 (op1 a1..am d1..dn)
     		      	--     	    	      	       	   (op2 a1..am d1..dn)
        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]
        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)
        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,
    }                           -- in positional order

That in turn allowed me to re-enable the DFunUnfolding specialisation in
DsBinds.  Lots of details here in TcInstDcls:
	  Note [SPECIALISE instance pragmas]

I also did some refactoring, in particular to pass the InScopeSet to
exprIsConApp_maybe (which in turn means it has to go to a RuleFun).

NB: Interface file format has changed!
parent cfb9bee7
......@@ -346,14 +346,13 @@ mkDictSelId dflags no_unf name clas
-- varToCoreExpr needed for equality superclass selectors
-- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
dictSelRule :: Int -> Arity
-> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
dictSelRule :: Int -> Arity -> RuleFun
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
dictSelRule val_index n_ty_args _ _ id_unf args
dictSelRule val_index n_ty_args _ id_unf _ args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (getNth con_args val_index)
......@@ -1082,8 +1081,7 @@ seqId = pcMiscPrelId seqName ty info
, ru_try = match_seq_of_cast
}
match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr]
-> Maybe CoreExpr
match_seq_of_cast :: RuleFun
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
......
......@@ -104,8 +104,17 @@ type InterestingVarFun = Var -> Bool
\begin{code}
type FV = InterestingVarFun
-> VarSet -- In scope
-> VarSet -- Locally bound
-> VarSet -- Free vars
-- Return the vars that are both (a) interesting
-- and (b) not locally bound
-- See function keep_it
keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
......@@ -152,13 +161,6 @@ someVars :: VarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope
= someVars (varTypeTyVars bndr) fv_cand in_scope
......@@ -434,15 +436,18 @@ idUnfoldingVars :: Id -> VarSet
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet
stableUnfoldingVars fv_cand unf
stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src -> Just (exprSomeFreeVars fv_cand rhs)
DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand (dfunArgExprs args))
_other -> Nothing
| isStableSource src
-> Just (exprFreeVars rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
-- DFuns are top level, so no fvs from types of bndrs
_other -> Nothing
\end{code}
......
......@@ -59,7 +59,6 @@ import Type hiding ( substTy, extendTvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
import TcType ( tcSplitDFunTy )
import TyCon ( tyConArity )
import DataCon
import PrelNames ( eqBoxDataConKey )
......@@ -78,7 +77,6 @@ import Maybes
import ErrUtils
import DynFlags
import BasicTypes ( isAlwaysActive )
import ListSetOps
import Util
import Pair
import Outputable
......@@ -656,10 +654,11 @@ substUnfoldingSC subst unf -- Short-cut version
| isEmptySubst subst = unf
| otherwise = substUnfolding subst unf
substUnfolding subst (DFunUnfolding ar con args)
= DFunUnfolding ar con (map subst_arg args)
substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= df { df_bndrs = bndrs', df_args = args' }
where
subst_arg = fmap (substExpr (text "dfun-unf") subst)
(subst',bndrs') = substBndrs subst bndrs
args' = map (substExpr (text "subst-unf:dfun") subst') args
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
......@@ -923,6 +922,8 @@ simple_opt_expr :: Subst -> InExpr -> OutExpr
simple_opt_expr subst expr
= go expr
where
in_scope_env = (substInScope subst, simpleUnfoldingFun)
go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
go (App e1 e2) = simple_app subst e1 [go e2]
go (Type ty) = Type (substTy subst ty)
......@@ -942,7 +943,7 @@ simple_opt_expr subst expr
go (Case e b ty as)
-- See Note [Optimise coercion boxes agressively]
| isDeadBinder b
, Just (con, _tys, es) <- expr_is_con_app e'
, Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
, Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
= case altcon of
DEFAULT -> go rhs
......@@ -1109,8 +1110,10 @@ add_info subst old_bndr new_bndr
| otherwise = maybeModifyIdInfo mb_new_info new_bndr
where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr])
expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding)
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun id
| isAlwaysActive (idInlineActivation id) = idUnfolding id
| otherwise = noUnfolding
\end{code}
Note [Inline prag in simplOpt]
......@@ -1158,12 +1161,10 @@ data ConCont = CC [CoreExpr] Coercion
-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
-- where t1..tk are the *universally-qantified* type args of 'dc'
exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe id_unf expr
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope, id_unf) expr
= go (Left in_scope) expr (CC [] (mkReflCo (exprType expr)))
where
in_scope = mkInScopeSet (exprFreeVars expr)
go :: Either InScopeSet Subst
-> CoreExpr -> ConCont
-> Maybe (DataCon, [Type], [CoreExpr])
......@@ -1184,17 +1185,13 @@ exprIsConApp_maybe id_unf expr
go (Left in_scope) (Var fun) cont@(CC args co)
| Just con <- isDataConWorkId_maybe fun
, count isValArg args == idArity fun
, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
= dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args)
= dealWithCoercion co con args
-- Look through dictionary functions; see Note [Unfolding DFuns]
| DFunUnfolding dfun_nargs con ops <- unfolding
, length args == dfun_nargs -- See Note [DFun arity check]
, let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunPolyArg e) = mkApps e args
mk_arg (DFunLamArg i) = getNth args i
= dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops)
| DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
, bndrs `equalLength` args -- See Note [DFun arity check]
, let subst = mkOpenSubst in_scope (bndrs `zip` args)
= dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args)
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
......@@ -1217,17 +1214,17 @@ exprIsConApp_maybe id_unf expr
subst_co (Right s) co = CoreSubst.substCo s co
subst_arg (Left {}) e = e
subst_arg (Right s) e = substExpr (text "exprIsConApp") s e
subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
extend (Right s) v e = Right (extendSubst s v e)
dealWithCoercion :: Coercion
-> (DataCon, [Type], [CoreExpr])
dealWithCoercion :: Coercion -> DataCon -> [CoreExpr]
-> Maybe (DataCon, [Type], [CoreExpr])
dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
dealWithCoercion co dc dc_args
| isReflCo co
= Just stuff
, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
= Just (dc, stripTypeArgs univ_ty_args, rest_args)
| Pair _from_ty to_ty <- coercionKind co
, Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
......@@ -1250,7 +1247,8 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
dc_ex_tyvars = dataConExTyVars dc
arg_tys = dataConRepArgTys dc
(ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
non_univ_args = dropList dc_univ_tyvars dc_args
(ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
......@@ -1263,10 +1261,11 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
ppr arg_tys, ppr dc_args,
ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ]
in
ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc )
ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args))
, dump_doc )
ASSERT2( all isTypeArg ex_args, dump_doc )
ASSERT2( equalLength val_args arg_tys, dump_doc )
Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
......@@ -1299,16 +1298,16 @@ type args) matches what the dfun is expecting. This may be *less*
than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\begin{code}
exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Same deal as exprIsConApp_maybe, but much simpler
-- Nevertheless we do need to look through unfoldings for
-- Integer literals, which are vigorously hoisted to top level
-- and not subsequently inlined
exprIsLiteral_maybe id_unf e
exprIsLiteral_maybe env@(_, id_unf) e
= case e of
Lit l -> Just l
Tick _ e' -> exprIsLiteral_maybe id_unf e' -- dubious?
Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
-> exprIsLiteral_maybe id_unf rhs
-> exprIsLiteral_maybe env rhs
_ -> Nothing
\end{code}
......@@ -49,7 +49,6 @@ module CoreSyn (
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
DFunArg(..), dfunArgExprs,
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
......@@ -78,7 +77,7 @@ module CoreSyn (
-- * Core rule data types
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
RuleName, IdUnfoldingFun,
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
-- ** Operations on 'CoreRule's
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
......@@ -92,6 +91,7 @@ module CoreSyn (
#include "HsVersions.h"
import CostCentre
import VarEnv( InScopeSet )
import Var
import Type
import Coercion
......@@ -577,13 +577,16 @@ data CoreRule
ru_fn :: Name, -- ^ As above
ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
-- if it fires, including type arguments
ru_try :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
ru_try :: RuleFun
-- ^ This function does the rewrite. It given too many
-- arguments, it simply discards them; the returned 'CoreExpr'
-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
}
-- See Note [Extra args in rule matching] in Rules.lhs
type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
type InScopeEnv = (InScopeSet, IdUnfoldingFun)
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
-- to do that in the Rule. The reason we need to pass this info in
......@@ -663,17 +666,15 @@ data Unfolding
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
| DFunUnfolding -- The Unfolding of a DFunId
| DFunUnfolding { -- The Unfolding of a DFunId
-- See Note [DFun unfoldings]
-- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
-- df = /\a1..am. \d1..dn. MkD t1 .. tk
-- (op1 a1..am d1..dn)
-- (op2 a1..am d1..dn)
Arity -- Arity = m+n, the *total* number of args
-- (unusually, both type and value) to the dfun
DataCon -- The dictionary data constructor (possibly a newtype datacon)
[DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order
df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn]
df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon)
df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
} -- in positional order
| CoreUnfolding { -- An unfolding for an Id with no pragma,
-- or perhaps a NOINLINE pragma
......@@ -710,20 +711,6 @@ data Unfolding
--
-- uf_guidance: Tells us about the /size/ of the unfolding template
------------------------------------------------
data DFunArg e -- Given (df a b d1 d2 d3)
= DFunPolyArg e -- Arg is (e a b d1 d2 d3)
| DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed
deriving( Functor )
-- 'e' is often CoreExpr, which are usually variables, but can
-- be trivial expressions instead (e.g. a type application).
dfunArgExprs :: [DFunArg e] -> [e]
dfunArgExprs [] = []
dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as
dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as
------------------------------------------------
data UnfoldingSource
......
......@@ -206,8 +206,11 @@ tidyIdBndr env@(tidy_env, var_env) id
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding tidy_env (DFunUnfolding ar con args) _
= DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) args)
tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
= df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
where
(tidy_env', bndrs') = tidyBndrs tidy_env bndrs
tidyUnfolding tidy_env
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
unf_from_rhs
......
......@@ -48,7 +48,6 @@ module CoreUnfold (
import DynFlags
import CoreSyn
import PprCore () -- Instances
import TcType ( tcSplitDFunTy )
import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy )
import CoreArity ( manifestArity, exprBotStrictness_maybe )
......@@ -98,13 +97,9 @@ mkImplicitUnfolding dflags expr
mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding
mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False
mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops
where
(tvs, theta, cls, _) = tcSplitDFunTy dfun_ty
dfun_nargs = length tvs + length theta
data_con = classDataCon cls
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
= DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops }
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule id expr arity
......
......@@ -429,8 +429,10 @@ instance Outputable UnfoldingSource where
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
<+> ppr con <+> brackets (pprWithCommas ppr ops)
ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
= hang (ptext (sLit "DFun:") <+> ptext (sLit "\\")
<+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (ppr con <+> sep (map ppr args))
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_work_free=wf
......@@ -451,10 +453,6 @@ instance Outputable Unfolding where
| otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
instance Outputable e => Outputable (DFunArg e) where
ppr (DFunPolyArg e) = braces (ppr e)
ppr (DFunLamArg i) = char '<' <> int i <> char '>'
\end{code}
-----------------------------------------------------
......
......@@ -447,24 +447,24 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
= putSrcSpanDs loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_name = mkClonedInternalName uniq poly_name
spec_occ = mkSpecOcc (getOccName poly_name)
spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (final_bndrs, _fn, args) -> do
Right (rule_bndrs, _fn, args) -> do
{ (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
; dflags <- getDynFlags
; let spec_id = mkLocalId spec_name spec_ty
{ dflags <- getDynFlags
; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id)
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
final_bndrs args
rule_bndrs args
(mkVarApps (Var spec_id) bndrs)
; spec_rhs <- dsHsWrapper spec_co poly_rhs
......@@ -472,7 +472,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
(warnDs (specOnInline poly_name))
; return (Just (spec_pair `consOL` unf_pairs, rule))
; return (Just (unitOL spec_pair, rule))
} } }
where
is_local_id = isJust mb_poly_rhs
......@@ -509,18 +509,15 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise = spec_prag_act -- Specified by user
specUnfolding :: HsWrapper -> Type
-> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to
generate unfoldings for specialised DFuns
specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding
specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs )
df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args }
where
subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args)
fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs
specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
= do { let spec_rhss = map wrap_fn ops
; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
-}
specUnfolding _ _ _
= return (noUnfolding, nilOL)
specUnfolding _ _ _ = noUnfolding
specOnInline :: Name -> MsgDoc
specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
......@@ -598,8 +595,8 @@ decomposeRuleLhs bndrs lhs
opt_lhs = simpleOptExpr lhs
check_bndrs fn args
| null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
| otherwise = Left (vcat (map dead_msg dead_bndrs))
| null dead_bndrs = Right (extra_dict_bndrs ++ bndrs, fn, args)
| otherwise = Left (vcat (map dead_msg dead_bndrs))
where
arg_fvs = exprsFreeVars args
......
......@@ -24,7 +24,6 @@ import TyCon
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
import CoreSyn (DFunArg(..))
import Coercion (LeftOrRight(..))
import TysWiredIn
import IfaceEnv
......@@ -1110,14 +1109,6 @@ instance Binary IfaceIdDetails where
1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
_ -> do { n <- get bh; return (IfDFunId n) }
instance Binary (DFunArg IfaceExpr) where
put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
put_ bh (DFunLamArg i) = putByte bh 1 >> put_ bh i
get bh = do { h <- getByte bh
; case h of
0 -> do { a <- get bh; return (DFunPolyArg a) }
_ -> do { a <- get bh; return (DFunLamArg a) } }
instance Binary IfaceIdInfo where
put_ bh NoInfo = putByte bh 0
put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
......@@ -1164,9 +1155,10 @@ instance Binary IfaceUnfolding where
putByte bh 3
put_ bh a
put_ bh n
put_ bh (IfDFunUnfold as) = do
put_ bh (IfDFunUnfold as bs) = do
putByte bh 4
put_ bh as
put_ bh bs
put_ bh (IfCompulsory e) = do
putByte bh 5
put_ bh e
......@@ -1188,7 +1180,8 @@ instance Binary IfaceUnfolding where
n <- get bh
return (IfExtWrapper a n)
4 -> do as <- get bh
return (IfDFunUnfold as)
bs <- get bh
return (IfDFunUnfold as bs)
_ -> do e <- get bh
return (IfCompulsory e)
......
......@@ -38,7 +38,6 @@ module IfaceSyn (
import TyCon( SynTyConRhs(..) )
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
import PprCore() -- Printing DFunArgs
import Demand
import Annotations
......@@ -255,7 +254,7 @@ data IfaceUnfolding
| IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
-- another module.
| IfDFunUnfold [DFunArg IfaceExpr]
| IfDFunUnfold [IfaceBndr] [IfaceExpr]
--------------------------------
data IfaceExpr
......@@ -769,8 +768,8 @@ instance Outputable IfaceUnfolding where
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext):") <+> ppr wkr
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfDFunUnfold ns) = ptext (sLit "DFun:")
<+> brackets (pprWithCommas ppr ns)
ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot)
2 (sep (map pprParendIfaceExpr es))
-- -----------------------------------------------------------------------------
-- | Finding the Names in IfaceSyn
......@@ -899,7 +898,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
......
......@@ -1746,8 +1746,8 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
where
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
......
......@@ -1244,15 +1244,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
(UnfWhen unsat_ok boring_ok))
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
= do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
tc_arg (DFunLamArg i) = return (DFunLamArg i)
(_, _, cls, _) = tcSplitDFunTy dfun_ty
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
......
......@@ -822,7 +822,8 @@ dffvLetBndr vanilla_unfold id
-- but I've seen cases where we had a wrapper id $w but a
-- rhs where $w had been inlined; see Trac #3922
go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args)
go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= extendScopeList bndrs $ mapM_ dffvExpr args
go_unf _ = return ()
go_rule (BuiltinRule {}) = return ()
......
This diff is collapsed.
......@@ -692,7 +692,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs)
-- Finding the free variables of the INLINE pragma (if any)
unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag
mb_unf_fvs = stableUnfoldingVars isLocalId unf
mb_unf_fvs = stableUnfoldingVars unf
-- Find the "nd_inl" free vars; for the loop-breaker phase
inl_fvs = case mb_unf_fvs of
......
......@@ -641,19 +641,21 @@ activeUnfolding env
where
mode = getMode env
getUnfoldingInRuleMatch :: SimplEnv -> IdUnfoldingFun
getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
-- When matching in RULE, we want to "look through" an unfolding
-- (to see a constructor) if *rules* are on, even if *inlinings*
-- are not. A notable example is DFuns, which really we want to
-- match in rules like (op dfun) in gentle mode. Another example
-- is 'otherwise' which we want exprIsConApp_maybe to be able to
-- see very early on
getUnfoldingInRuleMatch env id
| unf_is_active = idUnfolding id
| otherwise = NoUnfolding
getUnfoldingInRuleMatch env
= (in_scope, id_unf)
where
in_scope = seInScope env
mode = getMode env
unf_is_active
id_unf id | unf_is_active id = idUnfolding id
| otherwise = NoUnfolding
unf_is_active id
| not (sm_rules mode) = active_unfolding_minimal id
| otherwise = isActive (sm_phase mode) (idInlineActivation id)
......
......@@ -723,10 +723,10 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
-> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
= do { (env', bndrs') <- simplBinders env bndrs
; args' <- mapM (simplExpr env') args
; return (df { df_bndrs = bndrs', df_args = args' }) }
simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
......@@ -1559,8 +1559,8 @@ tryRules env rules fn args call_cont
= return Nothing
| otherwise
= do { dflags <- getDynFlags
; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env)
(getInScope env) fn args rules of {
; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
fn args rules of {
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->