Commit 90a8c94e authored by Simon Peyton Jones's avatar Simon Peyton Jones

Get rid of the DFunArg type and all its works

This type was mainly there to support silent superclass
parameters for dfuns, and they have gone away.  So this
patch is another minor simplification.

(Interface format change; you need to make clean.)
parent 0033d5a4
......@@ -450,7 +450,7 @@ idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
stableUnfoldingVars :: Unfolding -> VarSet
stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src = exprFreeVars rhs
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args)
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
stableUnfoldingVars _ = emptyVarSet
\end{code}
......
......@@ -623,7 +623,7 @@ substUnfoldingSC subst unf -- Short-cut version
substUnfolding subst (DFunUnfolding ar con args)
= DFunUnfolding ar con (map subst_arg args)
where
subst_arg = fmap (substExpr (text "dfun-unf") subst)
subst_arg = substExpr (text "dfun-unf") subst
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
......
......@@ -39,7 +39,6 @@ module CoreSyn (
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
DFunArg(..), dfunArgExprs,
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
......@@ -459,7 +458,7 @@ data Unfolding
DataCon -- The dictionary data constructor (possibly a newtype datacon)
[DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order
[CoreExpr] -- Specification of superclasses and methods, in positional order
| CoreUnfolding { -- An unfolding for an Id with no pragma,
-- or perhaps a NOINLINE pragma
......@@ -496,21 +495,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)
| DFunConstArg e -- Arg is e, which is constant
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 (DFunConstArg e : as) = e : dfunArgExprs as
------------------------------------------------
data UnfoldingSource
= InlineRhs -- The current rhs of the function
......
......@@ -198,7 +198,7 @@ tidyIdBndr env@(tidy_env, var_env) id
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding tidy_env (DFunUnfolding ar con ids) _
= DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids)
= DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
tidyUnfolding tidy_env
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
unf_from_rhs
......
......@@ -93,7 +93,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
mkSimpleUnfolding :: CoreExpr -> Unfolding
mkSimpleUnfolding = mkUnfolding InlineRhs False False
mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops
where
......@@ -1299,8 +1299,7 @@ exprIsConApp_maybe id_unf expr
pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False
, let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunConstArg e) = e
mk_arg (DFunPolyArg e) = mkApps e args
mk_arg e = mkApps e args
= Just (con, substTys subst dfun_res_tys, map mk_arg ops)
-- Look through unfoldings, but only cheap ones, because
......
......@@ -438,10 +438,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 (DFunConstArg e) = ppr e
\end{code}
-----------------------------------------------------
......
......@@ -18,7 +18,6 @@ import HscTypes
import BasicTypes
import Demand
import Annotations
import CoreSyn
import IfaceSyn
import Module
import Name
......@@ -1273,14 +1272,6 @@ instance Binary IfaceUnfolding where
_ -> do e <- get bh
return (IfCompulsory e)
instance Binary (DFunArg IfaceExpr) where
put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e
get bh = do { h <- getByte bh
; case h of
0 -> do { a <- get bh; return (DFunPolyArg a) }
_ -> do { a <- get bh; return (DFunConstArg a) } }
instance Binary IfaceNote where
put_ bh (IfaceSCC aa) = do
putByte bh 0
......
......@@ -27,8 +27,6 @@ module IfaceSyn (
#include "HsVersions.h"
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
......@@ -220,7 +218,7 @@ data IfaceUnfolding
| IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
-- another module.
| IfDFunUnfold [DFunArg IfaceExpr]
| IfDFunUnfold [IfaceExpr]
--------------------------------
data IfaceExpr
......@@ -826,7 +824,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 vs) = fnList freeNamesIfExpr vs
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
......
......@@ -1563,7 +1563,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
......
......@@ -1091,14 +1091,12 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
= do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
......
......@@ -726,7 +726,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
| show_unfolding src guide
-> Just (unf_ext_ids src unf_rhs)
DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
_ -> Nothing
where
unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
......
......@@ -707,7 +707,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
ops' = map (substExpr (text "simplUnfolding") env) ops
simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
......
......@@ -37,7 +37,7 @@ import Pair
--import VarSet
import CoreUtils ( mkPiTypes )
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr, varToCoreExpr )
import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr )
import Id
import MkId
import Name
......@@ -863,9 +863,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args
`setInlinePragma` dfunInlinePragma
dfun_args :: [DFunArg CoreExpr]
dfun_args = map (DFunPolyArg . varToCoreExpr) sc_args ++
map (DFunPolyArg . Var) meth_ids
dfun_args :: [CoreExpr]
dfun_args = map varToCoreExpr sc_args ++
map Var meth_ids
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
......
......@@ -73,7 +73,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
-- Set the unfolding for the inliner.
raw_dfun <- newExportedVar dfun_name dfun_ty
let dfun_unf = mkDFunUnfolding dfun_ty $
map (DFunPolyArg . Var) method_ids
map Var method_ids
dfun = raw_dfun `setIdUnfolding` dfun_unf
`setInlinePragma` dfunInlinePragma
......
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