Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
152e7032
Commit
152e7032
authored
Jan 15, 2013
by
Simon Peyton Jones
Browse files
When doing UNPACK pragmas, be careful to only unpack *data* types not newtypes
This was breaking tc226, following UNPACK-pragma reorg
parent
def97b82
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/MkId.lhs
View file @
152e7032
...
...
@@ -599,10 +599,10 @@ dataConArgRep _ _ arg_ty (HsUserBang _ False) -- No '!'
dataConArgRep dflags fam_envs arg_ty
(HsUserBang unpk_prag True) -- {-# UNPACK #-} !
| 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
-- 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
-- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty'
, (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
...
...
@@ -670,7 +670,10 @@ dataConArgUnpack
dataConArgUnpack arg_ty
| Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
, Just con <- tyConSingleDataCon_maybe tc
, Just con <- tyConSingleAlgDataCon_maybe tc
-- NB: check for an *algebraic* data type
-- A recursive newtype might mean that
-- 'arg_ty' is a newtype
, let rep_tys = dataConInstArgTys con tc_args
= ASSERT( isVanillaDataCon con )
( rep_tys `zip` dataConRepStrictness con
...
...
@@ -698,7 +701,7 @@ isUnpackableType :: FamInstEnvs -> Type -> Bool
-- end up relying on ourselves!
isUnpackableType fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, Just con <- tyConSingleDataCon_maybe tc
, Just con <- tyConSingle
Alg
DataCon_maybe tc
, isVanillaDataCon con
= ok_con_args (unitNameSet (getName tc)) con
| otherwise
...
...
@@ -713,7 +716,7 @@ isUnpackableType fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, let tc_name = getName tc
= not (tc_name `elemNameSet` tcs)
&& case tyConSingleDataCon_maybe tc of
&& case tyConSingle
Alg
DataCon_maybe tc of
Just con | isVanillaDataCon con
-> ok_con_args (tcs `addOneToNameSet` getName tc) con
_ -> True
...
...
compiler/types/TyCon.lhs
View file @
152e7032
...
...
@@ -56,7 +56,8 @@ module TyCon(
tyConUnique,
tyConTyVars,
tyConCType, tyConCType_maybe,
tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
tyConDataCons, tyConDataCons_maybe,
tyConSingleDataCon_maybe, tyConSingleAlgDataCon_maybe,
tyConFamilySize,
tyConStupidTheta,
tyConArity,
...
...
@@ -1380,6 +1381,13 @@ tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) =
tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c
tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c
tyConSingleDataCon_maybe _ = Nothing
tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon
-- Returns (Just con) for single-constructor *algebraic* data types
-- *not* newtypes
tyConSingleAlgDataCon_maybe (TupleTyCon {dataCon = c}) = Just c
tyConSingleAlgDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c
tyConSingleAlgDataCon_maybe _ = Nothing
\end{code}
\begin{code}
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment