summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/CoreFVs.lhs2
-rw-r--r--compiler/coreSyn/CoreSubst.lhs2
-rw-r--r--compiler/coreSyn/CoreSyn.lhs18
-rw-r--r--compiler/coreSyn/CoreTidy.lhs2
-rw-r--r--compiler/coreSyn/CoreUnfold.lhs5
-rw-r--r--compiler/coreSyn/PprCore.lhs4
-rw-r--r--compiler/iface/BinIface.hs9
-rw-r--r--compiler/iface/IfaceSyn.lhs6
-rw-r--r--compiler/iface/MkIface.lhs2
-rw-r--r--compiler/iface/TcIface.lhs4
-rw-r--r--compiler/main/TidyPgm.lhs2
-rw-r--r--compiler/simplCore/Simplify.lhs2
-rw-r--r--compiler/typecheck/TcInstDcls.lhs8
-rw-r--r--compiler/vectorise/Vectorise/Type/PADict.hs2
14 files changed, 17 insertions, 51 deletions
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 33017227b4..f88cb0be68 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -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}
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 0c954a8927..3ba8afaad3 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -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!
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 7582481091..872e732a61 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -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
@@ -497,21 +496,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
-- Replace uf_tmpl each time around
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 377bfd8c84..110fd72701 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -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
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index fe3772c2a8..f849dfa58d 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -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
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 8d0239d8e4..bd6cdf4c7f 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -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}
-----------------------------------------------------
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 1e24f34dd3..48a94c74e2 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -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
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 41732a9215..e03bc29326 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -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
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 42a4278b4f..3612372f8a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -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
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2187f03c61..32c0b2c801 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -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)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index c3be64b60a..71f7baf054 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -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])
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index b187897f89..a1cae1c5dd 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -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
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 33ad0f0f87..528bb0e4ec 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -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
diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs
index 3fc2d0aea3..ba2b3950a8 100644
--- a/compiler/vectorise/Vectorise/Type/PADict.hs
+++ b/compiler/vectorise/Vectorise/Type/PADict.hs
@@ -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
View Lorry Controller Status