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.

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index bb0089f..d4d8d2f 100644 (file)
--- 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
 
          -- (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
 
          -- 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
        ; 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
                                       (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 (file)
--- 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
   { 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
   ; 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)
 
   ; 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
        ; 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) }
     
 -----------------------------------
                 (emptyConDeclsErr tc_name) }
     
 -----------------------------------

-tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
+tcConDecls :: Bool -> TyCon -> ([TyVar], Type)

           -> [LConDecl Name] -> TcM [DataCon]
           -> [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
 
          -> 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)      $ 
          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
     ; (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
               ; buildDataCon (unLoc name) is_infix
                    stricts field_lbls
                    univ_tvs ex_tvs eq_preds ctxt' arg_tys

@@ -714,13 +711,10 @@ conRepresentibleWithH98Syntax
           f _ _ = False
 
 -------------------
           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
   = 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:
        ; 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
 --
 -- 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
   = 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
        HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
                          -- Source code never has shtes
   where