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.
By all means make it better! 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
