X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FTysPrim.lhs;h=e8638d78eef73b00daa970a718ee64183dcbbcb7;hp=4cb3ef7de401b364895fa728cb9755234f9accfc;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=3e0b6b2542d8464bfba365b97a6e4b95c3885f10

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 4cb3ef7..e8638d7 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -4,10 +4,17 @@
 \section[TysPrim]{Wired-in knowledge about primitive types}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module TysPrim(
 	alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
 	alphaTy, betaTy, gammaTy, deltaTy,
-	openAlphaTy, openAlphaTyVar, openAlphaTyVars,
+	openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
 
 	primTyCons,
 
@@ -39,7 +46,9 @@ module TysPrim(
 	word32PrimTyCon,	word32PrimTy,
 
 	int64PrimTyCon,		int64PrimTy,
-	word64PrimTyCon,	word64PrimTy
+	word64PrimTyCon,	word64PrimTy,
+
+	anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon
   ) where
 
 #include "HsVersions.h"
@@ -50,15 +59,16 @@ import OccName		( mkOccNameFS, tcName, mkTyVarOcc )
 import TyCon		( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
 			  PrimRep(..) )
 import Type		( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
-			  unliftedTypeKind, unboxedTypeKind, 
+			  unliftedTypeKind, 
 			  liftedTypeKind, openTypeKind, 
-			  Kind, mkArrowKinds,
+			  Kind, mkArrowKinds, mkArrowKind,
 			  TyThing(..)
 			)
-import SrcLoc		( noSrcLoc )
-import Unique		( mkAlphaTyVarUnique )
+import SrcLoc
+import Unique		( mkAlphaTyVarUnique, pprUnique )
 import PrelNames
-import FastString	( FastString, mkFastString )
+import StaticFlags
+import FastString
 import Outputable
 
 import Char 		( ord, chr )
@@ -97,13 +107,13 @@ primTyCons
     , wordPrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
+    , anyPrimTyCon, anyPrimTyCon1
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
 mkPrimTc fs uniq tycon
   = mkWiredInName gHC_PRIM (mkOccNameFS tcName fs) 
 		  uniq
-		  Nothing 		-- No parent object
 		  (ATyCon tycon)	-- Relevant TyCon
 		  UserSyntax		-- None are built-in syntax
 
@@ -131,6 +141,8 @@ stableNamePrimTyConName       = mkPrimTc FSLIT("StableName#") stableNamePrimTyCo
 bcoPrimTyConName 	      = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName  	      = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName  	      = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
+anyPrimTyConName	      = mkPrimTc FSLIT("Any") anyPrimTyConKey anyPrimTyCon
+anyPrimTyCon1Name	      = mkPrimTc FSLIT("Any1") anyPrimTyCon1Key anyPrimTyCon
 \end{code}
 
 %************************************************************************
@@ -146,7 +158,7 @@ alphaTyVars is a list of type variables for use in templates:
 tyVarList :: Kind -> [TyVar]
 tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) 
 				(mkTyVarOcc (mkFastString name))
-			 	noSrcLoc) kind
+			 	noSrcSpan) kind
 	         | u <- [2..],
 		   let name | c <= 'z'  = [c]
 		            | otherwise = 't':show u
@@ -168,9 +180,10 @@ alphaTys = mkTyVarTys alphaTyVars
 	-- to a lifted or unlifted type variable.  It's used for the 
 	-- result type for "error", so that we can have (error Int# "Help")
 openAlphaTyVars :: [TyVar]
-openAlphaTyVars@(openAlphaTyVar:_) = tyVarList openTypeKind
+openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind
 
 openAlphaTy = mkTyVarTy openAlphaTyVar
+openBetaTy   = mkTyVarTy openBetaTyVar
 \end{code}
 
 
@@ -187,17 +200,13 @@ pcPrimTyCon name arity rep
   = mkPrimTyCon name kind arity rep
   where
     kind        = mkArrowKinds (replicate arity liftedTypeKind) result_kind
-    result_kind = case rep of 
-		    PtrRep -> unliftedTypeKind
-		    _other -> unboxedTypeKind
+    result_kind = unliftedTypeKind
 
 pcPrimTyCon0 :: Name -> PrimRep -> TyCon
 pcPrimTyCon0 name rep
   = mkPrimTyCon name result_kind 0 rep
   where
-    result_kind = case rep of 
-		    PtrRep -> unliftedTypeKind
-		    _other -> unboxedTypeKind
+    result_kind = unliftedTypeKind
 
 charPrimTy	= mkTyConTy charPrimTyCon
 charPrimTyCon	= pcPrimTyCon0 charPrimTyConName WordRep
@@ -267,6 +276,53 @@ defined in \tr{TysWiredIn.lhs}, not here.
 
 %************************************************************************
 %*									*
+		Any
+%*									*
+%************************************************************************
+
+The type constructor Any is type to which you can unsafely coerce any
+lifted type, and back. 
+
+  * It is lifted, and hence represented by a pointer
+
+  * It does not claim to be a *data* type, and that's important for
+    the code generator, because the code gen may *enter* a data value
+    but never enters a function value.  
+
+It's also used to instantiate un-constrained type variables after type
+checking.  For example
+	length Any []
+Annoyingly, we sometimes need Anys of other kinds, such as (*->*) etc.
+This is a bit like tuples.   We define a couple of useful ones here,
+and make others up on the fly.  If any of these others end up being exported
+into interface files, we'll get a crash; at least until we add interface-file
+syntax to support them.
+
+\begin{code}
+anyPrimTy = mkTyConApp anyPrimTyCon []
+
+anyPrimTyCon :: TyCon 	-- Kind *
+anyPrimTyCon = mkLiftedPrimTyCon anyPrimTyConName liftedTypeKind 0 PtrRep
+
+anyPrimTyCon1 :: TyCon 	-- Kind *->*
+anyPrimTyCon1 = mkLiftedPrimTyCon anyPrimTyCon1Name kind 0 PtrRep
+  where
+    kind = mkArrowKind liftedTypeKind liftedTypeKind
+				  
+mkAnyPrimTyCon :: Unique -> Kind -> TyCon
+-- Grotesque hack alert: the client gives the unique; so equality won't work
+mkAnyPrimTyCon uniq kind 
+  = WARN( opt_PprStyle_Debug, ptext SLIT("Urk! Inventing strangely-kinded Any TyCon:") <+> ppr uniq <+> ppr kind )
+	-- See Note [Strangely-kinded void TyCons] in TcHsSyn
+    tycon
+  where
+     name  = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique uniq))) uniq tycon
+     tycon = mkLiftedPrimTyCon name kind 0 PtrRep
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection[TysPrim-arrays]{The primitive array types}
 %*									*
 %************************************************************************