Fix Trac #3966: warn about useless UNPACK pragmas
authorsimonpj@microsoft.com <unknown>
Thu, 6 May 2010 16:33:37 +0000 (16:33 +0000)
committersimonpj@microsoft.com <unknown>
Thu, 6 May 2010 16:33:37 +0000 (16:33 +0000)
Warning about useless UNPACK pragmas wasn't as easy as I thought.
I did quite a bit of refactoring, which improved the code by refining
the types somewhat.  In particular notice that in DataCon, we have

    dcStrictMarks   :: [HsBang]
    dcRepStrictness :: [StrictnessMarks]

The former relates to the *source-code* annotation, the latter to
GHC's representation choice.

15 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/hsSyn/HsTypes.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/main/PprTyThing.hs
compiler/parser/Parser.y.pp
compiler/prelude/TysWiredIn.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/vectorise/VectType.hs

index 33c6598..41a5fa5 100644 (file)
@@ -54,7 +54,8 @@ module BasicTypes(
 
         EP(..),
 
-       StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
+       HsBang(..), isBanged, isMarkedUnboxed, 
+        StrictnessMark(..), isMarkedStrict,
 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
@@ -529,24 +530,46 @@ The strictness annotations on types in data type declarations
 e.g.   data T = MkT !Int !(Bool,Bool)
 
 \begin{code}
-data StrictnessMark    -- Used in interface decls only
-   = MarkedStrict      
-   | MarkedUnboxed     
-   | NotMarkedStrict   
-   deriving( Eq )
+-------------------------
+-- HsBang describes what the *programmer* wrote
+-- This info is retained in the DataCon.dcStrictMarks field
+data HsBang = HsNoBang 
 
-isMarkedUnboxed :: StrictnessMark -> Bool
-isMarkedUnboxed MarkedUnboxed = True
-isMarkedUnboxed _             = False
+           | HsStrict  
 
-isMarkedStrict :: StrictnessMark -> Bool
-isMarkedStrict NotMarkedStrict = False
-isMarkedStrict _               = True   -- All others are strict
+           | HsUnpack         -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
+
+           | HsUnpackFailed   -- An UNPACK pragma that we could not make 
+                              -- use of, because the type isn't unboxable; 
+                               -- equivalant to HsStrict except for checkValidDataCon
+  deriving (Eq, Data, Typeable)
+
+instance Outputable HsBang where
+    ppr HsNoBang       = empty
+    ppr HsStrict       = char '!'
+    ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
+    ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
+
+isBanged :: HsBang -> Bool
+isBanged HsNoBang = False
+isBanged _        = True
+
+isMarkedUnboxed :: HsBang -> Bool
+isMarkedUnboxed HsUnpack = True
+isMarkedUnboxed _        = False
+
+-------------------------
+-- StrictnessMark is internal only, used to indicate strictness 
+-- of the DataCon *worker* fields
+data StrictnessMark = MarkedStrict | NotMarkedStrict   
 
 instance Outputable StrictnessMark where
   ppr MarkedStrict     = ptext (sLit "!")
-  ppr MarkedUnboxed    = ptext (sLit "!!")
-  ppr NotMarkedStrict  = ptext (sLit "_")
+  ppr NotMarkedStrict  = empty
+
+isMarkedStrict :: StrictnessMark -> Bool
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict _               = True   -- All others are strict
 \end{code}
 
 
index 6c4d583..406d02a 100644 (file)
@@ -327,7 +327,7 @@ data DataCon
                -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
 
        -- Now the strictness annotations and field labels of the constructor
-       dcStrictMarks :: [StrictnessMark],
+       dcStrictMarks :: [HsBang],
                -- Strictness annotations as decided by the compiler.  
                -- Does *not* include the existential dictionaries
                -- length = dataConSourceArity dataCon
@@ -478,7 +478,7 @@ instance Data.Data DataCon where
 -- | Build a new data constructor
 mkDataCon :: Name 
          -> Bool               -- ^ Is the constructor declared infix?
-         -> [StrictnessMark]   -- ^ Strictness annotations written in the source file
+         -> [HsBang]           -- ^ Strictness annotations written in the source file
          -> [FieldLabel]       -- ^ Field labels for the constructor, if it is a record, 
                                --   otherwise empty
          -> [TyVar]            -- ^ Universally quantified type variables
@@ -558,9 +558,9 @@ mkDataCon name declared_infix
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
 
-mk_dict_strict_mark :: PredType -> StrictnessMark
-mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
-                        | otherwise         = NotMarkedStrict
+mk_dict_strict_mark :: PredType -> HsBang
+mk_dict_strict_mark pred | isStrictPred pred = HsStrict
+                        | otherwise         = HsNoBang
 \end{code}
 
 \begin{code}
@@ -663,11 +663,11 @@ dataConFieldType con label
 
 -- | The strictness markings decided on by the compiler.  Does not include those for
 -- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
-dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks :: DataCon -> [HsBang]
 dataConStrictMarks = dcStrictMarks
 
 -- | Strictness of /existential/ arguments only
-dataConExStricts :: DataCon -> [StrictnessMark]
+dataConExStricts :: DataCon -> [HsBang]
 -- Usually empty, so we don't bother to cache this
 dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
 
@@ -913,7 +913,7 @@ deepSplitProductType str ty
       Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
 
 -- | Compute the representation type strictness and type suitable for a 'DataCon'
-computeRep :: [StrictnessMark]         -- ^ Original argument strictness
+computeRep :: [HsBang]                 -- ^ Original argument strictness
           -> [Type]                    -- ^ Original argument types
           -> ([StrictnessMark],        -- Representation arg strictness
               [Type])                  -- And type
@@ -921,10 +921,11 @@ computeRep :: [StrictnessMark]            -- ^ Original argument strictness
 computeRep stricts tys
   = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
   where
-    unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
-    unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
-    unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
-                               where
-                                 (_tycon, _tycon_args, arg_dc, arg_tys) 
-                                     = deepSplitProductType "unbox_strict_arg_ty" ty
+    unbox HsNoBang       ty = [(NotMarkedStrict, ty)]
+    unbox HsStrict       ty = [(MarkedStrict,    ty)]
+    unbox HsUnpackFailed ty = [(MarkedStrict,    ty)]
+    unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
+                      where
+                        (_tycon, _tycon_args, arg_dc, arg_tys) 
+                           = deepSplitProductType "unbox_strict_arg_ty" ty
 \end{code}
index 16c45b7..d0725bf 100644 (file)
@@ -244,9 +244,9 @@ mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon                    -- Newtype, only has a worker
   = DCIds Nothing nt_work_id                 
 
-  | any isMarkedStrict all_strict_marks      -- Algebraic, needs wrapper
-    || not (null eq_spec)                    -- NB: LoadIface.ifaceDeclSubBndrs
-    || isFamInstTyCon tycon                  --     depends on this test
+  | any isBanged all_strict_marks      -- Algebraic, needs wrapper
+    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclSubBndrs
+    || isFamInstTyCon tycon            --     depends on this test
   = DCIds (Just alg_wrap_id) wrk_id
 
   | otherwise                                -- Algebraic, no wrapper
@@ -334,8 +334,8 @@ mkDataConIds wrap_name wkr_name data_con
     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
     arg_dmds = map mk_dmd all_strict_marks
-    mk_dmd str | isMarkedStrict str = evalDmd
-               | otherwise          = lazyDmd
+    mk_dmd str | isBanged str = evalDmd
+               | otherwise    = lazyDmd
         -- The Cpr info can be important inside INLINE rhss, where the
         -- wrapper constructor isn't inlined.
         -- And the argument strictness can be important too; we
@@ -372,23 +372,21 @@ mkDataConIds wrap_name wkr_name data_con
                              in (y:ys,j)
 
     mk_case 
-           :: (Id, StrictnessMark)      -- Arg, strictness
+           :: (Id, HsBang)      -- Arg, strictness
            -> (Int -> [Id] -> CoreExpr) -- Body
            -> Int                       -- Next rep arg id
            -> [Id]                      -- Rep args so far, reversed
            -> CoreExpr
     mk_case (arg,strict) body i rep_args
           = case strict of
-                NotMarkedStrict -> body i (arg:rep_args)
-                MarkedStrict 
-                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
-                   | otherwise ->
-                        Case (Var arg) arg res_ty [(DEFAULT,[], body i (arg:rep_args))]
-
-                MarkedUnboxed
-                   -> unboxProduct i (Var arg) (idType arg) the_body 
+                HsNoBang -> body i (arg:rep_args)
+                HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body 
                       where
                         the_body i con_args = body i (reverse con_args ++ rep_args)
+                _other  -- HsUnpackFailed and HsStrict
+                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
+                   | otherwise -> Case (Var arg) arg res_ty 
+                                       [(DEFAULT,[], body i (arg:rep_args))]
 
 mAX_CPR_SIZE :: Arity
 mAX_CPR_SIZE = 10
index 9b39305..cb06a7f 100644 (file)
@@ -102,17 +102,6 @@ ppr_qq (HsQuasiQuote quoter _ quote) =
 type LBangType name = Located (BangType name)
 type BangType name  = HsType name      -- Bangs are in the HsType data type
 
-data HsBang = HsNoBang -- Only used as a return value for getBangStrictness,
-                       -- never appears on a HsBangTy
-           | HsStrict  -- ! 
-           | HsUnbox   -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-  deriving (Data, Typeable)
-
-instance Outputable HsBang where
-    ppr (HsNoBang) = empty
-    ppr (HsStrict) = char '!'
-    ppr (HsUnbox)  = ptext (sLit "!!")
-
 getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
 getBangType ty                    = ty
index 2931ffa..e608421 100644 (file)
@@ -613,16 +613,18 @@ instance Binary InlinePragma where
            d <- get bh
            return (InlinePragma a b c d)
 
-instance Binary StrictnessMark where
-    put_ bh MarkedStrict    = putByte bh 0
-    put_ bh MarkedUnboxed   = putByte bh 1
-    put_ bh NotMarkedStrict = putByte bh 2
+instance Binary HsBang where
+    put_ bh HsNoBang        = putByte bh 0
+    put_ bh HsStrict        = putByte bh 1
+    put_ bh HsUnpack        = putByte bh 2
+    put_ bh HsUnpackFailed  = putByte bh 3
     get bh = do
            h <- getByte bh
            case h of
-             0 -> do return MarkedStrict
-             1 -> do return MarkedUnboxed
-             _ -> do return NotMarkedStrict
+             0 -> do return HsNoBang
+             1 -> do return HsStrict
+             2 -> do return HsUnpack
+             _ -> do return HsUnpackFailed
 
 instance Binary Boxity where
     put_ bh Boxed   = putByte bh 0
index de1c191..738a5e3 100644 (file)
@@ -191,7 +191,7 @@ setAssocFamilyPermutation _clas_tvs other
 
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
-           -> [StrictnessMark
+           -> [HsBang
            -> [Name]                   -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext 
             -> [(TyVar,Type)]           -- Equality spec
@@ -306,7 +306,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 
        ; dict_con <- buildDataCon datacon_name
                                   False        -- Not declared infix
-                                  (map (const NotMarkedStrict) args)
+                                  (map (const HsNoBang) args)
                                   [{- No fields -}]
                                   tvs [{- no existentials -}]
                                    [{- No GADT equalities -}] [{- No theta -}]
index c844d62..44dd34a 100644 (file)
@@ -133,7 +133,7 @@ data IfaceConDecl
        ifConCtxt    :: IfaceContext,           -- Non-stupid context
        ifConArgTys  :: [IfaceType],            -- Arg types
        ifConFields  :: [OccName],              -- ...ditto... (field labels)
-       ifConStricts :: [StrictnessMark]}       -- Empty (meaning all lazy),
+       ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
                                                -- or 1-1 corresp with arg tys
 
 data IfaceInst 
@@ -524,10 +524,13 @@ pprIfaceConDecl tc
         if is_infix then ptext (sLit "Infix") else empty,
         if has_wrap then ptext (sLit "HasWrapper") else empty,
         ppUnless (null strs) $
-           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
         ppUnless (null fields) $
            nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
+    ppr_bang HsNoBang = char '_'       -- Want to see these
+    ppr_bang bang     = ppr bang
+        
     main_payload = ppr name <+> dcolon <+> 
                   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 
index 17d5d2a..ce6f4a3 100644 (file)
@@ -660,6 +660,24 @@ freeNamesDeclExtras IfaceOtherDeclExtras
 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
 
+instance Outputable IfaceDeclExtras where
+  ppr IfaceOtherDeclExtras       = empty
+  ppr (IfaceIdExtras  fix rules) = ppr_id_extras fix rules
+  ppr (IfaceSynExtras fix)       = ppr fix
+  ppr (IfaceDataExtras fix insts stuff)  = vcat [ppr fix, ppr_insts insts,
+                                                 ppr_id_extras_s stuff]
+  ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
+                                                 ppr_id_extras_s stuff]
+
+ppr_insts :: [IfaceInstABI] -> SDoc
+ppr_insts _ = ptext (sLit "<insts>")
+
+ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
+ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]
+
+ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
+ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)
+
 -- This instance is used only to compute fingerprints
 instance Binary IfaceDeclExtras where
   get _bh = panic "no get for IfaceDeclExtras"
index d87ffa1..dfa713f 100644 (file)
@@ -197,13 +197,9 @@ pprDataConDecl _ gadt_style show_label dataCon
     pp_tau = foldr add (ppr res_ty) tys_w_strs
     add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
 
-    pprParendBangTy (strict,ty)
-       | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty
-       | otherwise                 = GHC.pprParendType ty
+    pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
 
-    pprBangTy strict ty
-       | GHC.isMarkedStrict strict = char '!' <> ppr ty
-       | otherwise                 = ppr ty
+    pprBangTy bang ty = ppr bang <> ppr ty
 
     maybe_show_label (lbl,(strict,tp))
        | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
index 42cb96f..37f9ba6 100644 (file)
@@ -936,7 +936,7 @@ infixtype :: { LHsType RdrName }
 
 strict_mark :: { Located HsBang }
        : '!'                           { L1 HsStrict }
-       | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
+       | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
 
 -- A ctype is a for-all type
 ctype  :: { LHsType RdrName }
index 3689479..4695c87 100644 (file)
@@ -72,8 +72,7 @@ import TyCon          ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
                          mkTupleTyCon, mkAlgTyCon, tyConName,
                          TyConParent(NoParentTyCon) )
 
-import BasicTypes      ( Arity, RecFlag(..), Boxity(..), isBoxed,
-                         StrictnessMark(..) )
+import BasicTypes      ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
 
 import Type            ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
                          TyThing(..) )
@@ -238,7 +237,7 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
   = data_con
   where
     data_con = mkDataCon dc_name declared_infix
-                (map (const NotMarkedStrict) arg_tys)
+                (map (const HsNoBang) arg_tys)
                 []     -- No labelled fields
                 tyvars
                []      -- No existential type variables
index d5d6b6b..d7118e1 100644 (file)
@@ -1280,7 +1280,7 @@ checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 checkMissingFields data_con rbinds
   | null field_labels  -- Not declared as a record;
                        -- But C{} is still valid if no strict fields
-  = if any isMarkedStrict field_strs then
+  = if any isBanged field_strs then
        -- Illegal if any arg is strict
        addErrTc (missingStrictFields data_con [])
     else
@@ -1297,12 +1297,12 @@ checkMissingFields data_con rbinds
   where
     missing_s_fields
        = [ fl | (fl, str) <- field_info,
-                isMarkedStrict str,
+                isBanged str,
                 not (fl `elem` field_names_used)
          ]
     missing_ns_fields
        = [ fl | (fl, str) <- field_info,
-                not (isMarkedStrict str),
+                not (isBanged str),
                 not (fl `elem` field_names_used)
          ]
 
index d114efb..bafddf8 100644 (file)
@@ -1197,10 +1197,9 @@ reifyFixity name
       conv_dir BasicTypes.InfixL = TH.InfixL
       conv_dir BasicTypes.InfixN = TH.InfixN
 
-reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
-reifyStrict MarkedStrict    = TH.IsStrict
-reifyStrict MarkedUnboxed   = TH.IsStrict
-reifyStrict NotMarkedStrict = TH.NotStrict
+reifyStrict :: BasicTypes.HsBang -> TH.Strict
+reifyStrict bang | isBanged bang = TH.IsStrict
+                 | otherwise     = TH.NotStrict
 
 ------------------------------
 noTH :: LitString -> SDoc -> TcM a
index 1261131..47b8c31 100644 (file)
@@ -925,11 +925,11 @@ consUseH98Syntax _                                             = True
 -------------------
 tcConArg :: Bool               -- True <=> -funbox-strict_fields
           -> LHsType Name
-          -> TcM (TcType, StrictnessMark)
+          -> TcM (TcType, HsBang)
 tcConArg unbox_strict bty
   = do  { arg_ty <- tcHsBangType bty
        ; let bang = getBangStrictness bty
-        ; strict_mark <- chooseBoxingStrategy unbox_strict arg_ty bang
+        ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
        ; return (arg_ty, strict_mark) }
 
 -- We attempt to unbox/unpack a strict field when either:
@@ -938,31 +938,47 @@ tcConArg unbox_strict bty
 --
 -- We have turned off unboxing of newtypes because coercions make unboxing 
 -- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> TcM StrictnessMark
+chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
 chooseBoxingStrategy unbox_strict_fields arg_ty bang
   = case bang of
-       HsNoBang                        -> return NotMarkedStrict
-       HsUnbox  | can_unbox arg_ty     -> return MarkedUnboxed
-                 | otherwise            -> do { addWarnTc cant_unbox_msg
-                                              ; return MarkedStrict }
-       HsStrict | unbox_strict_fields 
-                 , can_unbox arg_ty    -> return MarkedUnboxed
-       _                               -> return MarkedStrict
+       HsNoBang                        -> HsNoBang
+       HsUnpack                        -> can_unbox HsUnpackFailed arg_ty
+       HsStrict | unbox_strict_fields  -> can_unbox HsStrict       arg_ty
+                | otherwise            -> HsStrict
+       HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
+                         -- Source code never has shtes
   where
-    -- we can unbox if the type is a chain of newtypes with a product tycon
-    -- at the end
-    can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
-                  Nothing                      -> False
-                  Just (arg_tycon, tycon_args) -> 
-                       not (isRecursiveTyCon arg_tycon) &&     -- Note [Recusive unboxing]
-                      isProductTyCon arg_tycon &&
-                       (if isNewTyCon arg_tycon then 
-                            can_unbox (newTyConInstRhs arg_tycon tycon_args)
-                        else True)
-
-    cant_unbox_msg = ptext (sLit "Ignoring unusable UNPACK pragma")
+    can_unbox :: HsBang -> TcType -> HsBang
+    -- Returns   HsUnpack  if we can unpack arg_ty
+    --                  fail_bang if we know what arg_ty is but we can't unpack it
+    --                  HsStrict  if it's abstract, so we don't know whether or not we can unbox it
+    can_unbox fail_bang arg_ty 
+       = case splitTyConApp_maybe arg_ty of
+           Nothing -> fail_bang
+
+           Just (arg_tycon, tycon_args) 
+              | isAbstractTyCon arg_tycon -> HsStrict  
+                      -- See Note [Don't complain about UNPACK on abstract TyCons]
+              | not (isRecursiveTyCon arg_tycon)       -- Note [Recusive unboxing]
+             , isProductTyCon arg_tycon 
+                   -- We can unbox if the type is a chain of newtypes 
+                   -- with a product tycon at the end
+              -> if isNewTyCon arg_tycon 
+                 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
+                 else HsUnpack
+
+              | otherwise -> fail_bang
 \end{code}
 
+Note [Don't complain about UNPACK on abstract TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are going to complain about UnpackFailed, but if we say
+   data T = MkT {-# UNPACK #-} !Wobble
+and Wobble is a newtype imported from a module that was compiled 
+without optimisation, we don't want to complain. Because it might
+be fine when optimsation is on.  I think this happens when Haddock
+is working over (say) GHC souce files.
+
 Note [Recursive unboxing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Be careful not to try to unbox this!
@@ -1110,9 +1126,15 @@ checkValidDataCon tc con
                -- Reason: it's really the argument of an equality constraint
        ; checkValidType ctxt (dataConUserType con)
        ; when (isNewTyCon tc) (checkNewDataCon con)
+        ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
+    check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
+    check_bang _                   = return ()
+
+    cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
+                           , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
 
 -------------------------------
 checkNewDataCon :: DataCon -> TcM ()
@@ -1124,7 +1146,7 @@ checkNewDataCon con
                -- Return type is (T a b c)
        ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
                -- No existentials
-       ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) 
+       ; checkTc (not (any isBanged (dataConStrictMarks con))) 
                  (newtypeStrictError con)
                -- No strictness
     }
index 83fd512..37d65db 100644 (file)
@@ -23,7 +23,7 @@ import FamInstEnv        ( FamInst, mkLocalFamInst )
 import OccName
 import Id
 import MkId
-import BasicTypes        ( StrictnessMark(..), boolToRecFlag,
+import BasicTypes        ( HsBang(..), boolToRecFlag,
                            alwaysInlinePragma, dfunInlinePragma )
 import Var               ( Var, TyVar, varType )
 import Name              ( Name, getOccName )
@@ -202,7 +202,7 @@ vectDataCon dc
 
       liftDs $ buildDataCon name'
                             False           -- not infix
-                            (map (const NotMarkedStrict) arg_tys)
+                            (map (const HsNoBang) arg_tys)
                             []              -- no labelled fields
                             univ_tvs
                             []              -- no existential tvs for now
@@ -693,7 +693,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
 
       liftDs $ buildDataCon dc_name
                             False                  -- not infix
-                            (map (const NotMarkedStrict) comp_tys)
+                            (map (const HsNoBang) comp_tys)
                             []                     -- no field labels
                             tvs
                             []                     -- no existentials