Commit 1ee1cd41 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Make {-# UNPACK #-} work for type/data family invocations

This fixes most of Trac #3990.  Consider
  data family D a
  data instance D Double = CD Int Int
  data T = T {-# UNPACK #-} !(D Double)
Then we want the (D Double unpacked).

To do this we need to construct a suitable coercion, and it's much
safer to record that coercion in the interface file, lest the in-scope
instances differ somehow.  That in turn means elaborating the HsBang
type to include a coercion.

To do that I moved HsBang from BasicTypes to DataCon, which caused
quite a few minor knock-on changes.

Interface-file format has changed!

Still to do: need to do knot-tying to allow instances to take effect
within the same module.
parent d3e2912a
......@@ -62,9 +62,6 @@ module BasicTypes(
EP(..),
HsBang(..), isBanged,
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
SwapFlag(..), flipSwap, unSwap,
......@@ -572,54 +569,6 @@ instance Outputable OccInfo where
| otherwise = empty
\end{code}
%************************************************************************
%* *
Strictness indication
%* *
%************************************************************************
The strictness annotations on types in data type declarations
e.g. data T = MkT !Int !(Bool,Bool)
\begin{code}
-------------------------
-- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field
data HsBang = HsNoBang -- Lazy field
| HsBang Bool -- Source-language '!' bang
-- True <=> also an {-# UNPACK #-} pragma
| HsUnpack -- Definite commitment: this field is strict and unboxed
| HsStrict -- Definite commitment: this field is strict but not unboxed
deriving (Eq, Data, Typeable)
instance Outputable HsBang where
ppr HsNoBang = empty
ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !")
ppr (HsBang False) = char '!'
ppr HsUnpack = ptext (sLit "Unpacked")
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged _ = True
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
data StrictnessMark = MarkedStrict | NotMarkedStrict
instance Outputable StrictnessMark where
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
isMarkedStrict _ = True -- All others are strict
\end{code}
%************************************************************************
%* *
Default method specfication
......
......@@ -14,7 +14,7 @@
module DataCon (
-- * Main data types
DataCon, DataConRep(..),
DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
ConTag,
-- ** Type construction
......@@ -39,6 +39,7 @@ module DataCon (
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
isBanged, isMarkedStrict, eqHsBang,
-- * Splitting product types
splitProductType_maybe, splitProductType,
......@@ -54,6 +55,7 @@ import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import Coercion
import Kind
import Unify
import TyCon
......@@ -436,6 +438,25 @@ data DataConRep
-- but that makes it less likely that rules will match
-- when we bring bits of unfoldings together.)
-------------------------
-- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field
data HsBang
= HsNoBang -- Lazy field
| HsBang Bool -- Source-language '!' bang
-- True <=> also an {-# UNPACK #-} pragma
| HsUnpack -- Definite commitment: this field is strict and unboxed
(Maybe Coercion) -- co :: arg-ty ~ product-ty
| HsStrict -- Definite commitment: this field is strict but not unboxed
deriving (Data.Data, Data.Typeable)
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
data StrictnessMark = MarkedStrict | NotMarkedStrict
-- | Type of the tags associated with each constructor possibility
type ConTag = Int
......@@ -515,6 +536,35 @@ instance Data.Data DataCon where
toConstr _ = abstractConstr "DataCon"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
ppr HsNoBang = empty
ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !")
ppr (HsBang False) = char '!'
ppr (HsUnpack Nothing) = ptext (sLit "Unpk")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
instance Outputable StrictnessMark where
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True
eqHsBang (HsBang b1) (HsBang b2) = b1 == b2
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
eqHsBang _ _ = False
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged _ = True
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
isMarkedStrict _ = True -- All others are strict
\end{code}
......
......@@ -47,7 +47,8 @@ import TysPrim
import TysWiredIn
import PrelRules
import Type
import Coercion ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo )
import FamInstEnv
import Coercion
import TcType
import MkCore
import CoreUtils ( exprType, mkCast )
......@@ -55,6 +56,7 @@ import CoreUnfold
import Literal
import TyCon
import Class
import NameSet
import VarSet
import Name
import PrimOp
......@@ -76,7 +78,6 @@ import Outputable
import FastString
import ListSetOps
import Data.List ( unzip4 )
import Data.Maybe ( maybeToList )
\end{code}
......@@ -365,18 +366,6 @@ dictSelRule val_index n_ty_args _ _ id_unf args
%************************************************************************
\begin{code}
type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
-- Unbox: bind rep vars by decomposing src var
data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
-- Box: build src arg using these rep vars
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
-- Bind these src-level vars, returning the
-- rep-level vars to bind in the pattern
\end{code}
\begin{code}
mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId wkr_name data_con
......@@ -458,9 +447,28 @@ dataConCPR con
-- things worse.
\end{code}
-------------------------------------------------
-- Data constructor representation
--
-- This is where we decide how to wrap/unwrap the
-- constructor fields
--
--------------------------------------------------
\begin{code}
mkDataConRep :: DynFlags -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags wrap_name data_con
type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
-- Unbox: bind rep vars by decomposing src var
data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
-- Box: build src arg using these rep vars
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
-- Bind these src-level vars, returning the
-- rep-level vars to bind in the pattern
mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name data_con
| not wrapper_reqd
= return NoDataConRep
......@@ -522,8 +530,9 @@ mkDataConRep dflags wrap_name data_con
-- Because we are going to apply the eq_spec args manually in the
-- wrapper
(wrap_bangs, rep_tys_w_strs, unboxers, boxers)
= unzip4 (zipWith (dataConArgRep dflags) all_arg_tys orig_bangs)
(wrap_bangs, rep_tys_w_strs, wrappers)
= unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
(unboxers, boxers) = unzip wrappers
(rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker
......@@ -573,50 +582,70 @@ newLocal ty = do { uniq <- getUniqueUs
-------------------------
dataConArgRep
:: DynFlags
-> FamInstEnvs
-> Type -> HsBang
-> ( HsBang -- Like input but with HsUnpackFailed if necy
, [(Type, StrictnessMark)] -- Rep types
, Unboxer, Boxer)
dataConArgRep _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], unitUnboxer, unitBoxer)
dataConArgRep dflags arg_ty (HsBang False) -- No {-# UNPACK #-} pragma
| gopt Opt_OmitInterfacePragmas dflags
= strict_but_not_unpacked arg_ty -- Don't unpack if we aren't optimising;
-- rather arbitrarily, we use -fomit-iface-pragmas
-- as the indication
| (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
, gopt Opt_UnboxStrictFields dflags
|| (gopt Opt_UnboxSmallStrictFields dflags
&& length rep_tys <= 1) -- See Note [Unpack one-wide fields]
= (HsUnpack, rep_tys, unbox, box)
, (Unboxer, Boxer) )
dataConArgRep _ _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag)
| not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-- Don't unpack if we aren't optimising;
-- rather arbitrarily, we use -fomit-iface-pragmas
-- as the indication
, let mb_co = topNormaliseType fam_envs arg_ty
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty'
, (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
, user_unpack_prag
|| gopt Opt_UnboxStrictFields dflags
|| (gopt Opt_UnboxSmallStrictFields dflags
&& length rep_tys <= 1) -- See Note [Unpack one-wide fields]
= case mb_co of
Nothing -> (HsUnpack Nothing, rep_tys, wrappers)
Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
| otherwise -- Record the strict-but-no-unpack decision
= strict_but_not_unpacked arg_ty
dataConArgRep dflags arg_ty (HsBang True) -- {-# UNPACK #-} pragma
| gopt Opt_OmitInterfacePragmas dflags
= strict_but_not_unpacked arg_ty -- Don't unpack if -fomit-iface-pragmas
dataConArgRep _ _ arg_ty HsStrict
= strict_but_not_unpacked arg_ty
| (something_happened, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
= (if something_happened then HsUnpack else HsStrict
, rep_tys, unbox, box)
dataConArgRep _ _ arg_ty (HsUnpack Nothing)
| (rep_tys, wrappers) <- dataConArgUnpack arg_ty
= (HsUnpack Nothing, rep_tys, wrappers)
dataConArgRep _ arg_ty HsStrict
= strict_but_not_unpacked arg_ty
dataConArgRep _ _ _ (HsUnpack (Just co))
| let co_rep_ty = pSnd (coercionKind co)
, (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
= (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
dataConArgRep _ arg_ty HsUnpack
| (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
= (HsUnpack, rep_tys, unbox, box)
| otherwise -- An interface file specified Unpacked, but we couldn't unpack it
= pprPanic "dataConArgRep" (ppr arg_ty)
strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], Unboxer, Boxer)
strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
strict_but_not_unpacked arg_ty
= (HsStrict, [(arg_ty, MarkedStrict)], seqUnboxer, unitBoxer)
= (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
-------------------------
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty
= (unboxer, boxer)
where
unboxer arg_id = do { rep_id <- newLocal rep_ty
; (rep_ids, rep_fn) <- unbox_rep rep_id
; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
; return (rep_ids, Let co_bind . rep_fn) }
boxer = Boxer $ \ subst ->
do { (rep_ids, rep_expr)
<- case box_rep of
UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
; return ([rep_id], Var rep_id) }
Boxer boxer -> boxer subst
; let sco = substCo (tvCvSubst subst) co
; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
------------------------
seqUnboxer :: Unboxer
seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])
......@@ -629,56 +658,63 @@ unitBoxer = UnitBox
-------------------------
dataConArgUnpack
:: Type
-> (Bool -- True <=> some unboxing actually happened
, [(Type, StrictnessMark)] -- Rep types
, Unboxer, Boxer)
-> ( [(Type, StrictnessMark)] -- Rep types
, (Unboxer, Boxer) )
dataConArgUnpack arg_ty
= case splitTyConApp_maybe arg_ty of
Just (tc, tc_args)
| not (isRecursiveTyCon tc) -- Note [Recusive unboxing]
, Just con <- tyConSingleDataCon_maybe tc
, isVanillaDataCon con
-> unbox_tc_app tc tc_args con
_otherwise -> ( False, [(arg_ty, MarkedStrict)]
, unitUnboxer, unitBoxer )
| Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
, Just con <- tyConSingleDataCon_maybe tc
, let rep_tys = dataConInstArgTys con tc_args
= ASSERT( isVanillaDataCon con )
( rep_tys `zip` dataConRepStrictness con
,( \ arg_id ->
do { rep_ids <- mapM newLocal rep_tys
; let unbox_fn body
= Case (Var arg_id) arg_id (exprType body)
[(DataAlt con, rep_ids, body)]
; return (rep_ids, unbox_fn) }
, Boxer $ \ subst ->
do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys
; return (rep_ids, Var (dataConWorkId con)
`mkTyApps` (substTys subst tc_args)
`mkVarApps` rep_ids ) } ) )
| otherwise
= pprPanic "dataConArgUnpack" (ppr arg_ty)
-- An interface file specified Unpacked, but we couldn't unpack it
isUnpackableType :: FamInstEnvs -> Type -> Bool
-- True if we can unpack the UNPACK fields of the constructor
-- without involving the NameSet tycons
isUnpackableType fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, Just con <- tyConSingleDataCon_maybe tc
, isVanillaDataCon con
= ok_con_args (unitNameSet (getName tc)) con
| otherwise
= False
where
unbox_tc_app tc tc_args con
| isNewTyCon tc
, let rep_ty = newTyConInstRhs tc tc_args
co = mkAxInstCo (newTyConCo tc) tc_args -- arg_ty ~ rep_ty
, (yes, rep_tys, unbox_rep, box_rep) <- dataConArgUnpack rep_ty
= ( yes, rep_tys
, \ arg_id ->
do { rep_id <- newLocal rep_ty
; (rep_ids, rep_fn) <- unbox_rep rep_id
; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
; return (rep_ids, Let co_bind . rep_fn) }
, Boxer $ \ subst ->
do { (rep_ids, rep_expr)
<- case box_rep of
UnitBox -> do { rep_id <- newLocal (substTy subst rep_ty)
; return ([rep_id], Var rep_id) }
Boxer boxer -> boxer subst
; let sco = mkAxInstCo (newTyConCo tc) (substTys subst tc_args)
; return (rep_ids, rep_expr `Cast` mkSymCo sco) } )
| otherwise
= ( True, rep_tys `zip` dataConRepStrictness con
, \ arg_id ->
do { rep_ids <- mapM newLocal rep_tys
; let unbox_fn body
= Case (Var arg_id) arg_id (exprType body)
[(DataAlt con, rep_ids, body)]
; return (rep_ids, unbox_fn) }
, Boxer $ \ subst ->
do { rep_ids <- mapM (newLocal . substTy subst) rep_tys
; return (rep_ids, Var (dataConWorkId con)
`mkTyApps` (substTys subst tc_args)
`mkVarApps` rep_ids ) } )
where
rep_tys = dataConInstArgTys con tc_args
ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty
where
norm_ty = case topNormaliseType fam_envs ty of
Just (_, ty) -> ty
Nothing -> ty
ok_ty tcs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, let tc_name = getName tc
= not (tc_name `elemNameSet` tcs)
&& case tyConSingleDataCon_maybe tc of
Just con | isVanillaDataCon con
-> ok_con_args (tcs `addOneToNameSet` getName tc) con
_ -> True
| otherwise
= True
ok_con_args tcs con
= all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
no_unpack (HsBang True) = False
no_unpack (HsUnpack {}) = False
no_unpack _ = True
\end{code}
Note [Unpack one-wide fields]
......@@ -734,7 +770,7 @@ space for each equality predicate, so it's pretty important!
\begin{code}
mk_pred_strict_mark :: PredType -> HsBang
mk_pred_strict_mark pred
| isEqPred pred = HsUnpack -- Note [Unpack equality predicates]
| isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates]
| otherwise = HsNoBang
\end{code}
......
......@@ -45,6 +45,7 @@ import HsLit
import NameSet( FreeVars )
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
import Type
import HsDoc
import BasicTypes
......
......@@ -748,21 +748,19 @@ instance Binary InlineSpec where
2 -> return Inlinable
_ -> return NoInline
instance Binary HsBang where
put_ bh HsNoBang = putByte bh 0
put_ bh (HsBang False) = putByte bh 1
put_ bh (HsBang True) = putByte bh 2
put_ bh HsUnpack = putByte bh 3
put_ bh HsStrict = putByte bh 4
instance Binary IfaceBang where
put_ bh IfNoBang = putByte bh 0
put_ bh IfStrict = putByte bh 1
put_ bh IfUnpack = putByte bh 2
put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
get bh = do
h <- getByte bh
case h of
0 -> do return HsNoBang
1 -> do return (HsBang False)
2 -> do return (HsBang True)
3 -> do return HsUnpack
_ -> do return HsStrict
0 -> do return IfNoBang
1 -> do return IfStrict
2 -> do return IfUnpack
_ -> do { a <- get bh; return (IfUnpackCo a) }
instance Binary TupleSort where
put_ bh BoxedTuple = putByte bh 0
......
......@@ -24,7 +24,7 @@ module BuildTyCl (
#include "HsVersions.h"
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import DataCon
import Var
import VarSet
......@@ -134,7 +134,8 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: Name -> Bool
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> [HsBang]
-> [Name] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
......@@ -148,7 +149,7 @@ buildDataCon :: Name -> Bool
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon src_name declared_infix arg_stricts field_lbls
buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
......@@ -166,7 +167,7 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
arg_tys res_ty rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags wrap_name data_con)
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
; return data_con }
......@@ -252,7 +253,8 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
; dict_con <- buildDataCon datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
(map (const HsNoBang) args)
[{- No fields -}]
......
......@@ -20,7 +20,7 @@ module IfaceSyn (
IfaceBinding(..), IfaceConAlt(..),
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceBang(..),
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
......@@ -149,9 +149,12 @@ data IfaceConDecl
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
data IfaceBang
= IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
data IfaceClsInst
= IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
......@@ -572,8 +575,10 @@ pprIfaceConDecl tc
ppUnless (null fields) $
nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
ppr_bang HsNoBang = char '_' -- Want to see these
ppr_bang bang = ppr bang
ppr_bang IfNoBang = char '_' -- Want to see these
ppr_bang IfStrict = char '!'
ppr_bang IfUnpack = ptext (sLit "!!")
ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceType co
main_payload = ppr name <+> dcolon <+>
pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
......
......@@ -1505,7 +1505,7 @@ tyConToIfaceDecl env tycon
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConRepBangs data_con }
ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
......@@ -1516,6 +1516,12 @@ tyConToIfaceDecl env tycon
to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
| (tv,ty) <- spec]
toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
toIfaceBang _ (HsBang {}) = panic "toIfaceBang"
classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
classToIfaceDecl env clas
......
......@@ -566,7 +566,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
ifConStricts = stricts})
ifConStricts = if_stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ name <- lookupIfaceTop occ
......@@ -583,11 +583,14 @@ tcIfaceDataCons tycon_name tycon _ if_cons
; return (eq_spec, theta, arg_tys) }
; lbl_names <- mapM lookupIfaceTop field_lbls
; stricts <- mapM tc_strict if_stricts
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
; buildDataCon name is_infix
; buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
stricts lbl_names
univ_tyvars ex_tyvars
eq_spec theta
......@@ -595,6 +598,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons
}
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
tc_strict IfNoBang = return HsNoBang
tc_strict IfStrict = return HsStrict
tc_strict IfUnpack = return (HsUnpack Nothing)
tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
; return (HsUnpack (Just co)) }
tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
......