Fix Trac #3966: warn about useless UNPACK pragmas

[ghc-hetmet.git] / compiler / iface / BuildTyCl.lhs

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index b8c04d3..738a5e3 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -20,7 +20,6 @@ import Var
 import VarSet
 import BasicTypes
 import Name
-import OccName
 import MkId
 import Class
 import TyCon
@@ -30,8 +29,6 @@ import Coercion
 import TcRnMonad
 import Util            ( count )
 import Outputable
-
-import Data.List
 \end{code}
        
 
@@ -79,9 +76,8 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
        ; tycon <- fixM (\ tycon_rec -> do 
         { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
         ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
-                                   fields parent is_rec want_generics gadt_syn
-              ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
-              ; fields  = mkTyConSelIds tycon rhs
+                                   parent is_rec want_generics gadt_syn
+              ; kind  = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
               }
          ; return tycon
          })
@@ -122,7 +118,18 @@ mkOpenDataTyConRhs = OpenTyCon Nothing
 
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
-  = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
+  = DataTyCon {
+        data_cons = cons,
+        is_enum = -- We define datatypes with no constructors to not be
+                  -- enumerations; this fixes trac #2578,  Otherwise we
+                  -- end up generating an empty table for
+                  --   <mod>_<type>_closure_tbl
+                  -- which is used by tagToEnum# to map Int# to constructors
+                  -- in an enumeration. The empty table apparently upset
+                  -- the linker.
+                  not (null cons) &&
+                  all isNullarySrcDataCon cons
+    }
 
 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 -- Monadic because it makes a Name for the coercion TyCon
@@ -184,7 +191,7 @@ setAssocFamilyPermutation _clas_tvs other
 
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
-           -> [StrictnessMark] 
+           -> [HsBang] 
            -> [Name]                   -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext 
             -> [(TyVar,Type)]           -- Equality spec
@@ -234,14 +241,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
     arg_tyvars      = tyVarsOfTypes arg_tys
     in_arg_tys pred = not $ isEmptyVarSet $ 
                      tyVarsOfPred pred `intersectVarSet` arg_tyvars
-
-------------------------------------------------------
-mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
-mkTyConSelIds tycon rhs
-  =  [ mkRecordSelId tycon fld 
-     | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
-       -- We'll check later that fields with the same name 
-       -- from different constructors have the same type.
 \end{code}
 
 
@@ -269,20 +268,11 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 
          let { rec_tycon  = classTyCon rec_clas
              ; op_tys     = [ty | (_,_,ty) <- sig_stuff]
+             ; op_names   = [op | (op,_,_) <- sig_stuff]
              ; op_items   = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
                             | (op_name, dm_info, _) <- sig_stuff ] }
                        -- Build the selector id and default method id
 
-       ; dict_con <- buildDataCon datacon_name
-                                  False        -- Not declared infix
-                                  (map (const NotMarkedStrict) op_tys)
-                                  [{- No labelled fields -}]
-                                  tvs [{- no existentials -}]
-                                   [{- No GADT equalities -}] sc_theta 
-                                   op_tys 
-                                  (mkTyConApp rec_tycon (mkTyVarTys tvs))
-                                  rec_tycon
-
        ; let n_value_preds   = count (not . isEqPred) sc_theta
              all_value_preds = n_value_preds == length sc_theta
              -- We only make selectors for the *value* superclasses, 
@@ -307,6 +297,23 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                -- i.e. exactly one operation or superclass taken together
                -- See note [Class newtypes and equality predicates]
 
+               -- We play a bit fast and loose by treating the superclasses
+               -- as ordinary arguments.  That means that in the case of
+               --     class C a => D a
+               -- we don't get a newtype with no arguments!
+             args    = sc_sel_names ++ op_names
+             arg_tys = map mkPredTy sc_theta ++ op_tys
+
+       ; dict_con <- buildDataCon datacon_name
+                                  False        -- Not declared infix
+                                  (map (const HsNoBang) args)
+                                  [{- No fields -}]
+                                  tvs [{- no existentials -}]
+                                   [{- No GADT equalities -}] [{- No theta -}]
+                                   arg_tys
+                                  (mkTyConApp rec_tycon (mkTyVarTys tvs))
+                                  rec_tycon
+
        ; rhs <- if use_newtype
                 then mkNewTyConRhs tycon_name rec_tycon dict_con
                 else return (mkDataTyConRhs [dict_con])