X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=f87397734370559665b9fde9a3888a1f3933cb34;hb=bf003a489bd426bfd44925e80b8442a7f8ea8d1c;hp=8d300d288ca5146e45d53ff9d69ca76fd18b3699;hpb=8ddec564494dc7889ea7aa8b4133f08cf3e64e0c;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 8d300d2..f873977 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -11,7 +11,7 @@ module DataCon (
 	dataConRepType, dataConSig, dataConFullSig,
 	dataConName, dataConTag, dataConTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
-	dataConEqSpec, dataConTheta, dataConStupidTheta, 
+	dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, 
 	dataConInstArgTys, dataConOrigArgTys, 
 	dataConInstOrigArgTys, dataConRepArgTys, 
 	dataConFieldLabels, dataConFieldType,
@@ -23,7 +23,8 @@ module DataCon (
 	isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
 	isVanillaDataCon, classDataCon, 
 
-	splitProductType_maybe, splitProductType,
+	splitProductType_maybe, splitProductType, deepSplitProductType,
+        deepSplitProductType_maybe
     ) where
 
 #include "HsVersions.h"
@@ -31,16 +32,17 @@ module DataCon (
 import Type		( Type, ThetaType, 
 			  substTyWith, substTyVar, mkTopTvSubst, 
 			  mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, 
-			  splitTyConApp_maybe, 
-			  mkPredTys, isStrictPred, pprType
+			  splitTyConApp_maybe, newTyConInstRhs, 
+			  mkPredTys, isStrictPred, pprType, mkPredTy
 			)
 import Coercion		( isEqPred, mkEqPred )
 import TyCon		( TyCon, FieldLabel, tyConDataCons, 
 			  isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
-                          isNewTyCon )
+                          isNewTyCon, isRecursiveTyCon )
 import Class		( Class, classTyCon )
-import Name		( Name, NamedThing(..), nameUnique )
-import Var		( TyVar, Id )
+import Name		( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
+import Var		( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
+                          mkCoVar )
 import BasicTypes	( Arity, StrictnessMark(..) )
 import Outputable
 import Unique		( Unique, Uniquable(..) )
@@ -48,6 +50,7 @@ import ListSetOps	( assoc, minusList )
 import Util		( zipEqual, zipWithEqual )
 import List		( partition )
 import Maybes           ( expectJust )
+import FastString
 \end{code}
 
 
@@ -101,22 +104,55 @@ data constructor.  The type checker translates it into either the wrapper Id
 
 The data con has one or two Ids associated with it:
 
-  The "worker Id", is the actual data constructor.
-	Its type may be different to the Haskell source constructor
-	because:
-		- useless dict args are dropped
-		- strict args may be flattened
-	The worker is very like a primop, in that it has no binding.
+The "worker Id", is the actual data constructor.
+* Every data constructor (newtype or data type) has a worker
 
-	Newtypes have no worker Id
+* The worker is very like a primop, in that it has no binding.
 
+* For a *data* type, the worker *is* the data constructor;
+  it has no unfolding
 
-  The "wrapper Id", $WC, whose type is exactly what it looks like
-	in the source program. It is an ordinary function,
-	and it gets a top-level binding like any other function.
+* For a *newtype*, the worker has a compulsory unfolding which 
+  does a cast, e.g.
+	newtype T = MkT Int
+	The worker for MkT has unfolding
+		\(x:Int). x `cast` sym CoT
+  Here CoT is the type constructor, witnessing the FC axiom
+	axiom CoT : T = Int
 
-	The wrapper Id isn't generated for a data type if the worker
-	and wrapper are identical.  It's always generated for a newtype.
+The "wrapper Id", $WC, goes as follows
+
+* Its type is exactly what it looks like in the source program. 
+
+* It is an ordinary function, and it gets a top-level binding 
+  like any other function.
+
+* The wrapper Id isn't generated for a data type if there is
+  nothing for the wrapper to do.  That is, if its defn would be
+	$wC = C
+
+Why might the wrapper have anything to do?  Two reasons:
+
+* Unboxing strict fields (with -funbox-strict-fields)
+	data T = MkT !(Int,Int)
+	$wMkT :: (Int,Int) -> T
+	$wMkT (x,y) = MkT x y
+  Notice that the worker has two fields where the wapper has 
+  just one.  That is, the worker has type
+		MkT :: Int -> Int -> T
+
+* Equality constraints for GADTs
+	data T a where { MkT :: a -> T [a] }
+
+  The worker gets a type with explicit equality
+  constraints, thus:
+	MkT :: forall a b. (a=[b]) => b -> T a
+
+  The wrapper has the programmer-specified type:
+	$wMkT :: a -> T [a]
+	$wMkT a x = MkT [a] a [a] x
+  The third argument is a coerion
+	[a] :: [a]:=:[a]
 
 
 
@@ -305,10 +341,9 @@ data DataCon
   }
 
 data DataConIds
-  = NewDC Id			-- Newtypes have only a wrapper, but no worker
-  | AlgDC (Maybe Id) Id 	-- Algebraic data types always have a worker, and
+  = DCIds (Maybe Id) Id 	-- Algebraic data types always have a worker, and
 				-- may or may not have a wrapper, depending on whether
-				-- the wrapper does anything.
+				-- the wrapper does anything.  Newtypes just have a worker
 
 	-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
 
@@ -316,7 +351,7 @@ data DataConIds
 	-- The worker takes dcRepArgTys as its arguments
 	-- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys
 
-	-- The 'Nothing' case of AlgDC is important
+	-- The 'Nothing' case of DCIds is important
 	-- Not only is this efficient,
 	-- but it also ensures that the wrapper is replaced
 	-- by the worker (becuase it *is* the wroker)
@@ -493,28 +528,24 @@ dataConTheta = dcTheta
 
 dataConWorkId :: DataCon -> Id
 dataConWorkId dc = case dcIds dc of
-			AlgDC _ wrk_id -> wrk_id
-			NewDC _ -> pprPanic "dataConWorkId" (ppr dc)
+			DCIds _ wrk_id -> wrk_id
 
 dataConWrapId_maybe :: DataCon -> Maybe Id
 -- Returns Nothing if there is no wrapper for an algebraic data con
 --		   and also for a newtype (whose constructor is inlined compulsorily)
 dataConWrapId_maybe dc = case dcIds dc of
-				AlgDC mb_wrap _ -> mb_wrap
-				NewDC wrap	-> Nothing
+				DCIds mb_wrap _ -> mb_wrap
 
 dataConWrapId :: DataCon -> Id
 -- Returns an Id which looks like the Haskell-source constructor
 dataConWrapId dc = case dcIds dc of
-			AlgDC (Just wrap) _   -> wrap
-			AlgDC Nothing     wrk -> wrk	    -- worker=wrapper
-			NewDC wrap	      -> wrap
+			DCIds (Just wrap) _   -> wrap
+			DCIds Nothing     wrk -> wrk	    -- worker=wrapper
 
 dataConImplicitIds :: DataCon -> [Id]
 dataConImplicitIds dc = case dcIds dc of
-			  AlgDC (Just wrap) work -> [wrap,work]
-			  AlgDC Nothing     work -> [work]
-			  NewDC wrap		 -> [wrap]
+			  DCIds (Just wrap) work -> [wrap,work]
+			  DCIds Nothing     work -> [work]
 
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels = dcFields
@@ -601,12 +632,13 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys,
  where
    tyvars = univ_tvs ++ ex_tvs
 
+
 -- And the same deal for the original arg tys
 dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys,
+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
 			       dcUnivTyVars = univ_tvs, 
 			       dcExTyVars = ex_tvs}) inst_tys
- = ASSERT( length tyvars == length inst_tys )
+ = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys )
    map (substTyWith tyvars inst_tys) arg_tys
  where
    tyvars = univ_tvs ++ ex_tvs
@@ -687,6 +719,21 @@ splitProductType str ty
 	Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 
+deepSplitProductType_maybe ty
+  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+       ; let {result 
+             | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+             = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive newtypes
+             | otherwise = Just res}
+       ; result
+       }
+          
+deepSplitProductType str ty 
+  = case deepSplitProductType_maybe ty of
+      Just stuff -> stuff
+      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+
 computeRep :: [StrictnessMark]		-- Original arg strictness
 	   -> [Type]			-- and types
 	   -> ([StrictnessMark],	-- Representation arg strictness
@@ -698,6 +745,7 @@ computeRep stricts tys
     unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
     unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
     unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
-			     where
-			       (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+                               where
+                                 (tycon, tycon_args, arg_dc, arg_tys) 
+                                     = deepSplitProductType "unbox_strict_arg_ty" ty
 \end{code}