On 11/06/2011 14:53, Simon Peyton Jones wrote:
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/792449f555bb4dfa8e718079f6d42dc9babe938a
---------------------------------------------------------------
commit 792449f555bb4dfa8e718079f6d42dc9babe938a
Author: Simon Peyton Jones<[email protected]>
Date: Sat Jun 11 14:26:34 2011 +0100
Ignore UNPACK pragmas with OmitInterfacePragmas is on (fixes Trac #5252)
The point here is that if a data type chooses a representation that
unpacks an argument field, the representation of the argument field
must be visible to clients. And it may not be if OmitInterfacePragmas
is on.
This seems a bit heavy-handed. If the type being UNPACKed is from
another module, then its representation must be available for UNPACK to
work, and hence it will also be available to clients. The problematic
case is only when all 3 of these hold:
- the type being UNPACKed is defined in the current module
- it is not exported (or exported abstractly),
- and the type with the UNPACK pragma is exported concretely
if any of these are false, we are OK. I think it would help to at least
check the first one - that would let the most common cases (e.g. UNPACK
Int) to still work without -O.
Cheers,
Simon
---------------------------------------------------------------
compiler/typecheck/TcInstDcls.lhs | 3 +-
compiler/typecheck/TcTyClsDecls.lhs | 44 +++++++++++++++++-----------------
2 files changed, 23 insertions(+), 24 deletions(-)
diff --git a/compiler/typecheck/TcInstDcls.lhs
b/compiler/typecheck/TcInstDcls.lhs
index bb0089f..d4d8d2f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -665,7 +665,6 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName
= L loc tc_name,
-- (2) type check indexed data type declaration
; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper
tyvars
- ; unbox_strict<- doptM Opt_UnboxStrictFields
-- kind check the type indexes and the context
; t_typats<- mapM tcHsKindedType k_typats
@@ -684,7 +683,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName
= L loc tc_name,
; let ex_ok = True -- Existentials ok for type families!
; fixM (\ rep_tycon -> do
{ let orig_res_ty = mkTyConApp fam_tycon t_typats
- ; data_cons<- tcConDecls unbox_strict ex_ok rep_tycon
+ ; data_cons<- tcConDecls ex_ok rep_tycon
(t_tvs, orig_res_ty) k_cons
; tc_rhs<-
case new_or_data of
diff --git a/compiler/typecheck/TcTyClsDecls.lhs
b/compiler/typecheck/TcTyClsDecls.lhs
index 8d62b78..ca4f2c5 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -482,7 +482,6 @@ tcTyClDecl1 _parent calc_isrec
{ extra_tvs<- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta<- tcHsKindedContext ctxt
- ; unbox_strict<- doptM Opt_UnboxStrictFields
; kind_signatures<- xoptM Opt_KindSignatures
; existential_ok<- xoptM Opt_ExistentialQuantification
; gadt_ok<- xoptM Opt_GADTs
@@ -496,8 +495,7 @@ tcTyClDecl1 _parent calc_isrec
; tycon<- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
- ; data_cons<- tcConDecls unbox_strict ex_ok
- tycon (final_tvs, res_ty) cons
+ ; data_cons<- tcConDecls ex_ok tycon (final_tvs, res_ty) cons
; tc_rhs<-
if null cons&& is_boot -- In a hs-boot file, empty cons means
then return AbstractTyCon -- "don't know"; hence Abstract
@@ -585,19 +583,18 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
(emptyConDeclsErr tc_name) }
-----------------------------------
-tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
+tcConDecls :: Bool -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
-tcConDecls unbox ex_ok rep_tycon res_tmpl cons
- = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
+tcConDecls ex_ok rep_tycon res_tmpl cons
+ = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons
-tcConDecl :: Bool -- True<=> -funbox-strict_fields
- -> Bool -- True<=> -XExistentialQuantificaton or -XGADTs
+tcConDecl :: Bool -- True<=> -XExistentialQuantificaton or
-XGADTs
-> TyCon -- Representation tycon
-> ([TyVar], Type) -- Return type template (with its template
tyvars)
-> ConDecl Name
-> TcM DataCon
-tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
+tcConDecl existential_ok rep_tycon res_tmpl -- Data types
con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
@@ -608,7 +605,7 @@ tcConDecl unbox_strict existential_ok rep_tycon res_tmpl
-- Data types
; (univ_tvs, ex_tvs, eq_preds, res_ty')<- tcResultType res_tmpl tvs'
res_ty
; let
tc_datacon is_infix field_lbls btys
- = do { (arg_tys, stricts)<- mapAndUnzipM (tcConArg unbox_strict) btys
+ = do { (arg_tys, stricts)<- mapAndUnzipM tcConArg btys
; buildDataCon (unLoc name) is_infix
stricts field_lbls
univ_tvs ex_tvs eq_preds ctxt' arg_tys
@@ -714,13 +711,10 @@ conRepresentibleWithH98Syntax
f _ _ = False
-------------------
-tcConArg :: Bool -- True<=> -funbox-strict_fields
- -> LHsType Name
- -> TcM (TcType, HsBang)
-tcConArg unbox_strict bty
+tcConArg :: LHsType Name -> TcM (TcType, HsBang)
+tcConArg bty
= do { arg_ty<- tcHsBangType bty
- ; let bang = getBangStrictness bty
- ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
+ ; strict_mark<- chooseBoxingStrategy arg_ty (getBangStrictness bty)
; return (arg_ty, strict_mark) }
-- We attempt to unbox/unpack a strict field when either:
@@ -729,13 +723,19 @@ tcConArg unbox_strict bty
--
-- We have turned off unboxing of newtypes because coercions make unboxing
-- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
-chooseBoxingStrategy unbox_strict_fields arg_ty bang
+chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang
+chooseBoxingStrategy arg_ty bang
= case bang of
- HsNoBang -> HsNoBang
- HsUnpack -> can_unbox HsUnpackFailed arg_ty
- HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
- | otherwise -> HsStrict
+ HsNoBang -> return HsNoBang
+ HsStrict -> do { unbox_strict<- doptM Opt_UnboxStrictFields
+ ; if unbox_strict then return (can_unbox HsStrict
arg_ty)
+ else return HsStrict }
+ HsUnpack -> do { omit_prags<- doptM Opt_OmitInterfacePragmas
+ -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
+ -- See Trac #5252: unpacking means we must not conceal the
+ -- representation of the argument type
+ ; if omit_prags then return HsStrict
+ else return (can_unbox HsUnpackFailed
arg_ty) }
HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
-- Source code never has shtes
where
_______________________________________________
Cvs-ghc mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/cvs-ghc
_______________________________________________
Cvs-ghc mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/cvs-ghc
