X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=4c570a0bddacbc8ef7b353b71670e4b888e9e084;hb=5e4375adca19f66803c3ad47fb1ba2c2ac6b4b62;hp=ba383d8d1d0fb9f1c0b122b8e54eb9ab9545a946;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index ba383d8..4c570a0 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module BuildTyCl (
 	buildSynTyCon, buildAlgTyCon, buildDataCon,
-	buildClass,
+	TcMethInfo, buildClass,
 	mkAbstractTyConRhs, mkOpenDataTyConRhs, 
 	mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
     ) where
@@ -118,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
@@ -180,7 +191,7 @@ setAssocFamilyPermutation _clas_tvs other
 
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
-	    -> [StrictnessMark] 
+	    -> [HsBang] 
 	    -> [Name]			-- Field labels
 	    -> [TyVar] -> [TyVar]	-- Univ and ext 
             -> [(TyVar,Type)]           -- Equality spec
@@ -235,14 +246,17 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 \begin{code}
+type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
+					     -- between tcClassSigs and buildClass
+
 buildClass :: Bool			-- True <=> do not include unfoldings 
 					--	    on dict selectors
 					-- Used when importing a class without -O
 	   -> Name -> [TyVar] -> ThetaType
-	   -> [FunDep TyVar]		-- Functional dependencies
-	   -> [TyThing]			-- Associated types
-	   -> [(Name, DefMeth, Type)]	-- Method info
-	   -> RecFlag			-- Info for type constructor
+	   -> [FunDep TyVar]		   -- Functional dependencies
+	   -> [TyThing]			   -- Associated types
+	   -> [TcMethInfo]                 -- Method info
+	   -> RecFlag			   -- Info for type constructor
 	   -> TcRnIf m n Class
 
 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
@@ -255,11 +269,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 
 	; fixM (\ rec_clas -> do {	-- Only name generation inside loop
 
-	  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 ] }
+	; op_items <- mapM (mk_op_item rec_clas) sig_stuff
 	  		-- Build the selector id and default method id
 
 	; let n_value_preds   = count (not . isEqPred) sc_theta
@@ -290,12 +300,15 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 		-- 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
-
+	      args      = sc_sel_names ++ op_names
+	      arg_tys   = map mkPredTy sc_theta ++ op_tys
+	      op_tys	= [ty | (_,_,ty) <- sig_stuff]
+	      op_names  = [op | (op,_,_) <- sig_stuff]
+              rec_tycon = classTyCon rec_clas
+               
 	; 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 -}]
@@ -328,6 +341,15 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 	; traceIf (text "buildClass" <+> ppr tycon) 
 	; return result
 	})}
+  where
+    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
+    mk_op_item rec_clas (op_name, dm_spec, _) 
+      = do { dm_info <- case dm_spec of
+                          NoDM      -> return NoDefMeth
+                          GenericDM -> return GenDefMeth
+                          VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+			  	          ; return (DefMeth dm_name) }
+           ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
 \end{code}
 
 Note [Class newtypes and equality predicates]