Implement "roles" into GHC.

Roles are a solution to the GeneralizedNewtypeDeriving type-safety
problem.

Roles were first described in the "Generative type abstraction" paper,
by Stephanie Weirich, Dimitrios Vytiniotis, Simon PJ, and Steve Zdancewic.
The implementation is a little different than that paper. For a quick
primer, check out Note [Roles] in Coercion. Also see
http://ghc.haskell.org/trac/ghc/wiki/Roles
and
http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation
For a more formal treatment, check out docs/core-spec/core-spec.pdf.

This fixes Trac #1496, #4846, #7148.

compiler/basicTypes/DataCon.lhs

@@ -650,11 +650,12 @@ mkDataCon name declared_infix
       | isJust (promotableTyCon_maybe rep_tycon)
           -- The TyCon is promotable only if all its datacons
           -- are, so the promoteType for prom_kind should succeed
-      = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
+      = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
       | otherwise 
       = Nothing          
     prom_kind = promoteType (dataConUserType con)
-    arity     = dataConSourceArity con
+    roles = map (const Nominal)          (univ_tvs ++ ex_tvs) ++
+            map (const Representational) orig_arg_tys
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
@@ -996,6 +997,7 @@ dataConCannotMatch tys con
 \begin{code}
 buildAlgTyCon :: Name 
               -> [TyVar]               -- ^ Kind variables and type variables
+              -> [Role]
 	      -> Maybe CType
 	      -> ThetaType	       -- ^ Stupid theta
 	      -> AlgTyConRhs
@@ -1005,14 +1007,14 @@ buildAlgTyCon :: Name
               -> TyConParent
 	      -> TyCon
 
-buildAlgTyCon tc_name ktvs cType stupid_theta rhs 
+buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs 
               is_rec is_promotable gadt_syn parent
   = tc
   where 
     kind = mkPiKinds ktvs liftedTypeKind
 
     -- tc and mb_promoted_tc are mutually recursive
-    tc = mkAlgTyCon tc_name kind ktvs cType stupid_theta 
+    tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta 
                     rhs parent is_rec gadt_syn 
                     mb_promoted_tc
 

compiler/basicTypes/MkId.lhs

@@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
     initial_wrap_app = Var (dataConWorkId data_con)
                       `mkTyApps`  res_ty_args
     	              `mkVarApps` ex_tvs                 
-    	              `mkCoApps`  map (mkReflCo . snd) eq_spec
+    	              `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
     	                -- Dont box the eq_spec coercions since they are
     	                -- marked as HsUnpack by mk_dict_strict_mark
 
@@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr
     wrapFamInstBody tycon args $
     mkCast result_expr (mkSymCo co)
   where
-    co = mkUnbranchedAxInstCo (newTyConCo tycon) args
+    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
 
 -- When unwrapping, we do *not* apply any family coercion, because this will
 -- be done via a CoPat by the type checker.  We have to do it this way as
@@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
-    mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args)
+    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -843,15 +843,15 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args))
+  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
   | otherwise
   = body
 
 -- Same as `wrapFamInstBody`, but for type family instances, which are
 -- represented by a `CoAxiom`, and not a `TyCon`
 wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
 wrapTypeFamInstBody axiom ind args body
-  = mkCast body (mkSymCo (mkAxInstCo axiom ind args))
+  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
 
 wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
 wrapTypeUnbranchedFamInstBody axiom
@@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only
+  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only
   | otherwise
   = scrut
 
 unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
 unwrapTypeFamInstScrut axiom ind args scrut
-  = mkCast scrut (mkAxInstCo axiom ind args)
+  = mkCast scrut (mkAxInstCo Representational axiom ind args)
 
 unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
 unwrapTypeUnbranchedFamInstScrut axiom

compiler/cmm/SMRep.lhs

@@ -16,6 +16,11 @@ module SMRep (
         WordOff, ByteOff,
         roundUpToWords,
 
+#if __GLASGOW_HASKELL__ > 706
+        -- ** Immutable arrays of StgWords
+        UArrayStgWord, listArray, toByteArray,
+#endif
+
         -- * Closure repesentation
         SMRep(..), -- CmmInfo sees the rep; no one else does
         IsStatic,
@@ -49,8 +54,13 @@ import DynFlags
 import Outputable
 import Platform
 import FastString
+import qualified Data.Array.Base as Array
+
+#if __GLASGOW_HASKELL__ > 706
+import GHC.Base ( ByteArray# )
+import Data.Ix
+#endif
 
-import Data.Array.Base
 import Data.Char( ord )
 import Data.Word
 import Data.Bits
@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64
 #if __GLASGOW_HASKELL__ < 706
               Num,
 #endif
-              Bits, IArray UArray)
+
+#if __GLASGOW_HASKELL__ <= 706
+              Array.IArray Array.UArray,
+#endif
+              Bits)
 
 fromStgWord :: StgWord -> Integer
 fromStgWord (StgWord i) = toInteger i
@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
 hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+                Immutable arrays of StgWords
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+
+#if __GLASGOW_HASKELL__ > 706
+-- TODO: Improve with newtype coercions!
+
+newtype UArrayStgWord i = UArrayStgWord (Array.UArray i Word64)
+
+listArray :: Ix i => (i, i) -> [StgWord] -> UArrayStgWord i
+listArray (i,j) words
+  = UArrayStgWord $ Array.listArray (i,j) (map unStgWord words)
+  where unStgWord (StgWord w64) = w64
+
+toByteArray :: UArrayStgWord i -> ByteArray#
+toByteArray (UArrayStgWord (Array.UArray _ _ _ b)) = b
+
+#endif
+
+\end{code}
 
 %************************************************************************
 %*                                                                      *