summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinIface.hs13
-rw-r--r--compiler/iface/IfaceSyn.lhs10
-rw-r--r--compiler/iface/MkIface.lhs4
-rw-r--r--compiler/iface/TcIface.lhs8
4 files changed, 24 insertions, 11 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 3ef6d0998a..6cfcb8c201 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -24,6 +24,7 @@ import DataCon (dataConName, dataConWorkId, dataConTyCon)
import IParam (ipFastString, ipTyConName)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
+import CoreSyn (DFunArg(..))
import TysWiredIn
import IfaceEnv
import HscTypes
@@ -1194,13 +1195,21 @@ instance Binary IfaceBinding where
instance Binary IfaceIdDetails where
put_ bh IfVanillaId = putByte bh 0
put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
- put_ bh IfDFunId = putByte bh 2
+ put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n }
get bh = do
h <- getByte bh
case h of
0 -> return IfVanillaId
1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
- _ -> return IfDFunId
+ _ -> 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
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index b53398da7d..bc5fc954eb 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -35,6 +35,8 @@ module IfaceSyn (
#include "HsVersions.h"
import IfaceType
+import CoreSyn( DFunArg, dfunArgExprs )
+import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
@@ -194,7 +196,7 @@ type IfaceAnnTarget = AnnTarget OccName
data IfaceIdDetails
= IfVanillaId
| IfRecSelId IfaceTyCon Bool
- | IfDFunId
+ | IfDFunId Int -- Number of silent args
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
@@ -237,7 +239,7 @@ data IfaceUnfolding
| IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
-- another module.
- | IfDFunUnfold [IfaceExpr]
+ | IfDFunUnfold [DFunArg IfaceExpr]
--------------------------------
data IfaceExpr
@@ -701,7 +703,7 @@ instance Outputable IfaceIdDetails where
ppr IfVanillaId = empty
ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
<+> if b then ptext (sLit "<naughty>") else empty
- ppr IfDFunId = ptext (sLit "DFunId")
+ ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
@@ -856,7 +858,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
-freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 0ccab30ae5..1e1da3c5bf 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1645,7 +1645,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
-toIfaceIdDetails (DFunId {}) = IfDFunId
+toIfaceIdDetails (DFunId ns _) = IfDFunId ns
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
@@ -1710,7 +1710,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 toIfaceExpr ops)))
+ = Just (HsUnfold lb (IfDFunUnfold (map (fmap 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 e7360dc935..4a37dde284 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1161,8 +1161,8 @@ do_one (IfaceRec pairs) thing_inside
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
-tcIdDetails ty IfDFunId
- = return (DFunId (isNewTyCon (classTyCon cls)))
+tcIdDetails ty (IfDFunId ns)
+ = return (DFunId ns (isNewTyCon (classTyCon cls)))
where
(_, _, cls, _) = tcSplitDFunTy ty
@@ -1226,12 +1226,14 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
- = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+ = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg 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 (DFunLamArg i) = return (DFunLamArg i)
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
View Lorry Controller Status