From 792449f555bb4dfa8e718079f6d42dc9babe938a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Sat, 11 Jun 2011 14:26:34 +0100 Subject: [PATCH] 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. --- 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 -- 1.7.10.4