Fix Trac #3966: warn about useless UNPACK pragmas

[ghc-hetmet.git] / compiler / basicTypes / DataCon.lhs

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 8f09078..406d02a 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -54,6 +54,7 @@ import Util
 import FastString
 import Module
 
+import qualified Data.Data as Data
 import Data.Char
 import Data.Word
 import Data.List ( partition )
@@ -326,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
@@ -341,7 +342,8 @@ data DataCon
                                        -- after unboxing and flattening,
                                        -- and *including* existential dictionaries
 
-       dcRepStrictness :: [StrictnessMark],    -- One for each *representation* argument       
+       dcRepStrictness :: [StrictnessMark],
+        -- One for each *representation* *value* argument
                -- See also Note [Data-con worker strictness] in MkId.lhs
 
        -- Result type of constructor is T t1..tn
@@ -454,6 +456,15 @@ instance Outputable DataCon where
 
 instance Show DataCon where
     showsPrec p con = showsPrecSDoc p (ppr con)
+
+instance Data.Typeable DataCon where
+    typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") []
+
+instance Data.Data DataCon where
+    -- don't traverse?
+    toConstr _   = abstractConstr "DataCon"
+    gunfold _ _  = error "gunfold"
+    dataTypeOf _ = mkNoRepType "DataCon"
 \end{code}
 
 
@@ -467,7 +478,7 @@ instance Show 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
@@ -547,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}
@@ -652,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
 
@@ -902,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
@@ -910,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}