On 14/06/2011 10:41, Simon Peyton-Jones wrote:
Yes one could do better. But it's not particularly easy to do so. So the
cost-benefit ratio (where cost = implementation time, and resultant code
complexity) didn't seem good to me. I've fixed a crash, at the expense of
de-optimising certain programs where you compile some modules with -O and
others without.
Hmm, it's not just when you're using a mixture of -O0 and -O1, is it?
The UNPACK is always ignored.
By all means make it better!
OK! (someday...)
Cheers,
Simon
Simon
| -----Original Message-----
| From: Simon Marlow [mailto:[email protected]]
| Sent: 14 June 2011 10:02
| To: Simon Peyton-Jones
| Cc: [email protected]
| Subject: Re: [commit: ghc] master: Ignore UNPACK pragmas with
OmitInterfacePragmas is
| on (fixes Trac #5252) (792449f)
|
| 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/792449f555bb4dfa8e718079f6d42dc9babe938
| a
|>
|>> ---------------------------------------------------------------
|>
|> 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
